So Reference to My old question here that was solved by @VBasic2008, it worked quite well.
Code:
Sub CreateSummary()
' Define constants.
' Source
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const SOURCE_FILTER_COLUMN_INDEX As Long = 4
' Destination
Const DESTINATION_NAME As String = "Sheet2"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.Count
If scCount < SOURCE_FILTER_COLUMN_INDEX Then Exit Sub ' too few columns
' Write the values from the filter column ('srfg') to an array ('sData').
Dim sfrg As Range: Set sfrg = srg.Columns(SOURCE_FILTER_COLUMN_INDEX)
Dim sData() As Variant: sData = sfrg.Value
' Return the unique values and their number of occurrences
' in a dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sString As String
Dim sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, 1))
If Len(sString) > 0 Then dict(sString) = dict(sString) 1 ' count
Next sr
If dict.Count = 0 Then Exit Sub ' only error values or blanks
Erase sData
' Reference the first destination cell ('dCell').
Application.ScreenUpdating = False
Dim dsh As Object
On Error Resume Next
Set dsh = wb.Sheets(DESTINATION_NAME)
On Error GoTo 0
If Not dsh Is Nothing Then
Application.DisplayAlerts = False
dsh.Delete
Application.DisplayAlerts = True
End If
Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=sws)
dws.Name = DESTINATION_NAME
Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.Rows(1).Copy
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
dCell.Select
' Copy the filtered ranges one below the other.
Dim sKey As Variant
For Each sKey In dict.Keys
srg.AutoFilter SOURCE_FILTER_COLUMN_INDEX, sKey
srg.Copy dCell
sws.ShowAllData
Set dCell = dCell.Offset(DESTINATION_GAP dict(sKey) 1)
Next sKey
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
MsgBox "Summary created.", vbInformation
End Sub
CodePudding user response：
Please, test the next updated code. It uses other two dictionaries (one for unique company codes and another one to keep the occurrences for each combination Company code - Filter criteria:
Sub CreateSummaryTwoFilters()
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const FILTER_COLUMN1_INDEX As Long = 1
Const FILTER_COLUMN2_INDEX As Long = 4
' Destination
Const DESTINATION_NAME As String = "Sheet2"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.rows.count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.count
If scCount < FILTER_COLUMN2_INDEX Then Exit Sub ' too few columns
'place all the range in an array for faster iteration:
Dim sData() As Variant: sData = srg.Value
' Return the unique values of cells in A:A and D:D and the number of occurrences for each concatenated pair:
Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
dictA.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
dictD.CompareMode = vbTextCompare
Dim dictAD As Object: Set dictAD = CreateObject("Scripting.Dictionary")
dictAD.CompareMode = vbTextCompare
Dim sString As String, sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, FILTER_COLUMN2_INDEX))
If Len(sData(sr, 1)) > 0 Then dictA(sData(sr, 1)) = vbNullString
If Len(sString) > 0 Then dictD(sString) = vbNullString
dictAD(sData(sr, 1) & "_" & sData(sr, 4)) = dictAD(sData(sr, 1) & "_" & sData(sr, 4)) 1 'count rows of both occurrence on the same row
Next sr
Application.ScreenUpdating = False
Dim dws As Worksheet
On Error Resume Next
Set dws = wb.Sheets(DESTINATION_NAME)
On Error GoTo 0
If Not dws Is Nothing Then
dws.cells.ClearContents
Else
Set dws = wb.Worksheets.Add(After:=sws)
dws.name = DESTINATION_NAME
End If
Dim dCell As Range: Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.rows(1).Copy ' copy the headers columns width
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
' Copy the filtered ranges one after the other.
Dim sKeyA As Variant, sKeyD As Variant
For Each sKeyA In dictA.Keys 'iterate between each key of company codes dictionary
For Each sKeyD In dictD.Keys 'Iterate between each key of D:D criteria dictionary
srg.AutoFilter FILTER_COLUMN1_INDEX, sKeyA 'place the filters:
srg.AutoFilter FILTER_COLUMN2_INDEX, sKeyD
srg.Copy dCell 'copy the filtered range
'if no any filter row resulted, writhe the keys combination on the headers row (after the last column):
If dictAD(sKeyA & "_" & sKeyD) = "" Then dCell.Offset(, scCount).Value = sKeyA & "_" & sKeyD
sws.ShowAllData:
Set dCell = dCell.Offset(DESTINATION_GAP dictAD(sKeyA & "_" & sKeyD) 1) 'reinitialize the cell where to paste next time
Next sKeyD
Next sKeyA
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
dws.Activate
MsgBox "Summary created.", vbInformation
End Sub
Please, send some feedback after testing it.
Edited:
Please, test the next version, which should do what (I understood) you need. I had some problems with the fact that the code used to stop after inserting a worksheet... I added code lines to stop events, calculation etc.:
Sub CreateSummaryTwoFiltersPerCompCode()
Const SOURCE_NAME As String = "Sheet1"
Const SOURCE_FIRST_CELL_ADDRESS As String = "A1"
Const FILTER_COLUMN1_INDEX As Long = 1
Const FILTER_COLUMN2_INDEX As Long = 4
' Destination
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_GAP As Long = 1 ' empty rows in-between
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_NAME)
If sws.FilterMode Then sws.ShowAllData
Dim srg As Range
Set srg = sws.Range(SOURCE_FIRST_CELL_ADDRESS).CurrentRegion
Dim srCount As Long: srCount = srg.rows.count
If srCount = 1 Then Exit Sub ' only headers or empty worksheet
Dim scCount As Long: scCount = srg.Columns.count
If scCount < FILTER_COLUMN2_INDEX Then Exit Sub ' too few columns
'place all the range in an array for faster iteration:
Dim sData() As Variant: sData = srg.Value
' Return the unique values of cells in A:A and D:D and the number of occurrences for each concatenated pair:
Dim dictA As Object: Set dictA = CreateObject("Scripting.Dictionary")
dictA.CompareMode = vbTextCompare
Dim dictD As Object: Set dictD = CreateObject("Scripting.Dictionary")
dictD.CompareMode = vbTextCompare
Dim dictAD As Object: Set dictAD = CreateObject("Scripting.Dictionary")
dictAD.CompareMode = vbTextCompare
Dim sString As String, sr As Long
For sr = 2 To srCount
sString = CStr(sData(sr, FILTER_COLUMN2_INDEX))
If Len(sData(sr, 1)) > 0 Then dictA(sData(sr, 1)) = vbNullString
If Len(sString) > 0 Then dictD(sString) = vbNullString
dictAD(sData(sr, 1) & "_" & sData(sr, 4)) = dictAD(sData(sr, 1) & "_" & sData(sr, 4)) 1 'count rows of both occurrence on the same row
Next sr
Application.ScreenUpdating = False
' Copy the filtered ranges one after the other.
Dim sKeyA As Variant, sKeyD As Variant, dws As Object, dCell As Range
For Each sKeyA In dictA.Keys 'iterate between each key of company codes dictionary
'insert a new sheet per company code:
Set dws = Nothing
On Error Resume Next
Set dws = wb.Sheets(sKeyA)
On Error GoTo 0
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
'a lot of measures to avoid stopping the code after the sheet insertion...
Application.EnableEvents = False: Application.Calculation = xlCalculationManual
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set dws = wb.Worksheets.Add(After:=sws)
dws.name = sKeyA
DoEvents
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.EnableEvents = True: Application.Calculation = xlCalculationAutomatic
Set dCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
' Copy column widths.
srg.rows(1).Copy ' copy the headers columns width
dCell.Resize(, scCount).PasteSpecial xlPasteColumnWidths
For Each sKeyD In dictD.Keys 'Iterate between each key of D:D criteria dictionary
srg.AutoFilter FILTER_COLUMN1_INDEX, sKeyA 'place the filters:
srg.AutoFilter FILTER_COLUMN2_INDEX, sKeyD
If dictAD(sKeyA & "_" & sKeyD) <> "" Then
srg.Copy dCell 'copy the filtered range
sws.ShowAllData
Set dCell = dCell.Offset(DESTINATION_GAP dictAD(sKeyA & "_" & sKeyD) 1) 'reinitialize the cell where to paste next time
End If
Next sKeyD
Next sKeyA
sws.AutoFilterMode = False
'wb.Save
Application.ScreenUpdating = True
' Inform.
dws.Activate
MsgBox "Summary created.", vbInformation
End Sub