List all values from that meet a criteria-CodePudding

Currently i have a macro which clears the values only out of "D3:D1000" in the current sheet then looks at a sheet called "SCHEDULE CALCULATIONS" searches through column "O" and looks for match (the value is defined in "A1" of current sheet), when a match is found it copies the values from column "A" of the same row and pastes it into the current sheet starting at "D3"and working its way though until all matches have been found and moves onto the next sheet and does the same until all sheets that except for the sheets that have been defined to not do are done.

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

While this works it takes along time as at the moment there are 26 sheets to go through. i know this code is way too inefficient and i don't know enough to make something better. any help would be greatly appreciated.

CodePudding user response：

When doing several thousand searches across the same set of values, it would be faster to just load the data into a Dictionary. With a pre-loaded Dictionary, you would only need to search the dictionary once per sheet, and then retrieve all the values.

Before your loop, add a loop that goes though the SCHEDULE CALCULATIONS sheet and adds each Column O value as a key into the dictionary, the dictionary item will be the Column A range. If there are multiple rows with the same Key (Column O) then we can add the ranges together, so the item will essentially become a collection of Column A cells (one collection per Column O value).

Once you have this Dictionary, each worksheet can find all the matching values from the dictionary by doing Dictionary(MyValue). But that will error if MyValue isn't in the dictionary, so it is important to first check If Dictionary.Exists(MyValue) Then. Once you have the collection of Ranges from your value, it is a simple task to output them to Column 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