所以參考@VBasic2008 解決的我的老問題，它作業得很好。
代碼：
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
uj5u.com熱心網友回復：
請測驗下一個更新的代碼。它使用其他兩個字典（一個用于唯一的公司代碼，另一個用于保留每個組合公司代碼的出現 - 過濾條件：
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
請在測驗后發送一些反饋。
編輯：
請測驗下一個版本，它應該做你需要的（我理解）。我遇到了一些問題，即在插入作業表后代碼會停止……我添加了代碼行來停止事件、計算等：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/ruanti/514487.html
標籤：擅长vba