列出符合条件的所有值

Question

目前我有一个宏，它只清除当前工作表中“D3：D1000”中的值，然后查看名为“SCHEDULE CALCULATIONS”的工作表，通过“O”列搜索并查找匹配项（该值在当前工作表的“A1”），当找到匹配项时，它会复制同一行的“A”列中的值并将其粘贴到从“D3”开始的当前工作表中，并一直工作直到找到所有匹配项，并且移动到下一张纸上并执行相同的操作，直到除了已定义为不做的图纸之外的所有图纸都完成​​为止。

Sub FILL_CHASSIS_REF()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "GALVANISED" And ws.Name <> "ALUMINUM" And ws.Name <> "LOTUS" And ws.Name <> "TEMPLATE" And ws.Name <> "SCHEDULE CALCULATIONS" And ws.Name <> "TRUSS" And ws.Name <> "DASHBOARD CALCULATIONS" And ws.Name <> "GALVANISING CALCULATIONS" Then
With ws.Range("D3:D1000")
    .Formula2R1C1 = _
        "=IF(ROWS(R2C25:R[-1]C[21])<=COUNTIF('SCHEDULE CALCULATIONS'!R2C15:R1000C15,R1C1),INDEX('SCHEDULE CALCULATIONS'!R2C1:R1000C1,AGGREGATE(15,3,('SCHEDULE CALCULATIONS'!R2C15:R1000C15=R1C1)/('SCHEDULE CALCULATIONS'!R2C15:R1000C15=R1C1)*(ROW('SCHEDULE CALCULATIONS'!R2C15:R1000C15)-{1}),ROWS(R2C25:R[-1]C[21]))),"""")"
    .Value = .Value
   End With
   
End If

Next ws

End Sub

虽然这项工作需要时间，因为目前有 26 张纸要通过。 我知道这段代码效率太低，而且我知道的东西还不够好。 任何帮助将不胜感激。

Answer 1

在对同一组值进行数千次搜索时，将数据加载到Dictionary 会更快。使用预加载的字典，您只需在每张纸上搜索一次字典，然后检索所有值。

在你的循环之前，添加一个循环，通过SCHEDULE CALCULATIONS 表并将每个 Column O 值作为键添加到字典中，字典项将是 A 列范围。如果有多行具有相同的键（O 列），那么我们可以将范围相加，因此该项目本质上将成为 A 列单元格的集合（每个 O 列值一个集合）。

一旦你有了这个字典，每个工作表都可以通过Dictionary(MyValue)从字典中找到所有匹配的值。但如果MyValue 不在字典中，这将出错，因此首先检查If Dictionary.Exists(MyValue) Then 很重要。从值中收集到 Ranges 集合后，将它们输出到 D 列是一项简单的任务。

Sub FILL_CHASSIS_REF()
    Dim Cell As Range

    Dim SchCals As Worksheet
    Set SchCals = Worksheets("SCHEDULE CALCULATIONS")
    
    'Creating a Dictionary
    Dim ColumnValues As Object
    Set ColumnValues = CreateObject("Scripting.Dictionary")
    
    'Looping through O2:O1000 of SCHEDULE CALCULATIONS
    
    For Each Cell In SchCals.Range("O2:O1000").Cells
        
        'If the value isnt empty
        If Not IsEmpty(Cell.Value) Then
            'if the dictionary doesn't already have this, add it
            If Not ColumnValues.Exists(CStr(Cell.Value)) Then
                'Dictionary Key is the Column O value and the Item is the Column A range
                ColumnValues.Add CStr(Cell.Value), Cell.EntireRow.Cells(1, 1)
            Else
            'if the dictionary already has this value, add the ranges together
                Set ColumnValues(CStr(Cell.Value)) = Union(ColumnValues(CStr(Cell.Value)), Cell.EntireRow.Cells(1, 1))
            End If
        End If
    Next
    
    'For each worksheet
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        'Excluding these worksheets
        If ws.Name <> "GALVANISED" And ws.Name <> "ALUMINUM" And ws.Name <> "LOTUS" And ws.Name <> "TEMPLATE" And ws.Name <> "SCHEDULE CALCULATIONS" And ws.Name <> "TRUSS" And ws.Name <> "DASHBOARD CALCULATIONS" And ws.Name <> "GALVANISING CALCULATIONS" Then
        
            'Saving the value from Cell A1
            Dim A1 As String: A1 = CStr(ws.Cells(1, 1).Value)
            
            'If the dictionary has this value
            If ColumnValues.Exists(A1) Then
                Dim i As Long
                i = 3 'Index for Column D
                
                'For each range saved in the dictionary for this value
                For Each Cell In ColumnValues(A1).Cells
                    ws.Cells(i, 4).Value = Cell.Value 'Put each value into Column D, starting from 3
                    i = i + 1
                Next
            End If
        End If
    
    Next ws

End Sub