VBA - Add row of data to dictionary if condition met.

[Trebor8484]

Hi all,

Any suggestions how I can amend the below code so that if the condition is true the entire row values are copied to the dictionary to be output to a worksheet at the end of the process.

This will run on over 100,000 rows of data so I was trying to find a way to prevent having to interact with the sheet on each loop iteration and figured that it would be quicker to store in memory then dump it into a sheet at the end of the loop

Sub Test()


    Dim c As Range
    Dim rng As Range
    Dim arrwords As Variant
    Dim aword As Variant
    Dim dict As Scripting.Dictionary
    Dim DictKey As Long


    Set dict = New Scripting.Dictionary
    
    Set rng = Sheet1.Range("A2:A" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row)
    
    arrwords = Array("apple", "pair")
    DictKey = 0


    For Each c In rng
        For Each aword In arrwords
            Debug.Print c
            If InStr(1, LCase(c.Value), aword, vbBinaryCompare) > 0 Then
                DictKey = DictKey + 1
                dict.Add DictKey, c.Row 
            End If
        Next aword
    Next c
    
    Sheet2.Cells(1, 1).Resize(dict.Count, 15).Value = (dict.Items)


End Sub

 

[Fluff]

How many words do you need to filter on?

 

[Trebor8484]

Testing approximately 100,000 rows for about 20 different words that may be in the string

 

[Fluff]

How about

Sub Trebor8484()
   Dim Ary As Variant, AryWrds As Variant
   Dim i As Long, j As Long
   
   AryWrds = Array("Tom", "D1ck", "Harry")
   Ary = Sheet1.Range("A2", Sheet1.Range("A" & Rows.Count).End(xlUp)).Value2
   With CreateObject("Scripting.dictionary")
      For i = 1 To UBound(Ary)
         For j = 0 To UBound(AryWrds)
            If InStr(1, Ary(i, 1), AryWrds(j), vbTextCompare) > 0 Then
               .Item(Ary(i, 1)) = Empty
            End If
         Next j
      Next i
      Sheet1.Range("A1").AutoFilter 1, .keys, xlFilterValues
      Sheet1.AutoFilter.Range.Offset(1).EntireRow.Copy Sheet2.Range("A1")
      Sheet1.AutoFilterMode = False
   End With
End Sub