列出满足条件的所有值

Question

目前我有一个宏，它只清除当前 sheet 中“D3:D1000”中的值，然后查看名为“SCHEDULE CALCULATIONS”的 sheet 搜索列“O”并查找匹配项（该值在当前 sheet 的“A1”中定义），当找到匹配项时，它会从同一行的“A”列复制值并将其粘贴到当前 sheet ] 从“D3”开始，一直进行直到找到所有匹配项，然后移动到下一个 sheet 并执行相同的操作，直到除了 sheet 之外的所有 sheet已定义不做已做。

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 sheet 秒要完成。我知道这段代码效率太低，而且我知道的不够多，无法做出更好的东西。任何帮助将不胜感激。

Answer 1

在同一组值中进行数千次搜索时，将数据加载到 Dictionary 中会更快。使用 pre-loaded 字典，您只需要为每个 sheet 搜索一次字典，然后检索所有值。

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

有了这个字典后，每个作品sheet都可以通过Dictionary(MyValue)从字典中找到所有匹配的值。但是如果 MyValue 不在字典中就会出错，所以首先检查 If Dictionary.Exists(MyValue) Then 很重要。从您的值中收集范围后，将它们输出到 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

列出满足条件的所有值

List all values from that meet a criteria

excel

vba

compare

list