Trying to search for list of strings using Arrays,Scripting Dictionary or FileSystemObject

I have been able to achieve this many different ways, but my methods become obsolete if there are too many rows.
My first attempt was something like this:

sub search()
Dim listVals as variant
Dim dataVals as variant
Dim i as long
Dim x as long
Dim list as worksheet
Dim data as worksheet
Dim results as range

Set list = Sheets("Sheet1")
Set data = Sheets("Sheet2")
Set results = Sheets("Sheet3").Range("A" & Sheets("Sheet3").Cells.SpecialCells(xlcellTypeLastCell).Row) 

listVals = list.Range("A1:A" & Cells.SpecialCells(xlCellTypeLastCell).Row)
dataVals = data.Range("A1:A150000")

For i = ubound(listVals,1) to lbound(listVals,1) Step -1
     For x = ubound(dataVals,1) to lbound(dataVals,1) Step -1
          if listVals(i,1) = dataVals(x,1) then
               nextRow = results + 1
               list.range("A" & i  & ":" & "G" & i).Copy Destination:= nextRow
               data.range("A" & x  & ":" & "G" & x).Copy Destination:= nextRow.Offset(0,7) 
          End if
     Next
Next
        
End Sub

This worked fine for smaller groups of data, but with 150,000 rows, this code brings my computer to its knees. I also tried using .Find, and it got even slower.. My final attempts were with Scripting.Dictionary and FileSystemObject, seemed as if they would have worked much better, but I couldn't quite get either to work correctly.

So if anyone can code a search that can look through > 200,000 rows
-Find a match,
-Select the first blank row on Results Sheet,
-Return the entire row of corresponding data from sheet1,
-Skip a column, and continue adding the entire row of corresponding data from sheet2 (so that everything is on the same row)
-repeat for all occurrences of all strings in ColumnA of a list sheet
it would be greatly appreciated!

That's really close, looks like matched rows from sheet2 are being returned, but nothing from sheet1

Please attach a sample

I wrote the attached to a question on this forum. The question and format of the answer appear to be very similar.
Try it

I wrote the attached to a question on this forum. The question and format of the answer appear to be very similar to your request.
Try it

Sorry, Should have done that from the start:

That one is close too.. Maybe the code i have been using can explain it better than i can word it:

Sub Sample()
Dim listSh As Worksheet, dataSh As Worksheet, newRow As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next

Set listSh = Sheets("Sample LIST")
Set dataSh = Sheets("Sample DATA")

vArray = listSh.Range("A1:A" & listSh.Cells.SpecialCells(xlCellTypeLastCell).Row)
vArray2 = dataSh.Range("A1:A" & dataSh.Cells.SpecialCells(xlCellTypeLastCell).Row)
        
    For i = UBound(vArray, 1) To LBound(vArray, 1) Step -1
        For x = UBound(vArray2, 1) To LBound(vArray2, 1) Step -1
            
            Set newRow = Sheets("Sample Results").Range("A1").End(xlDown).Offset(1, 0)
            
            If vArray(i, 1) = vArray2(x, 1) Then
                
                listSh.Range("A" & i & ":" & "G" & i).Copy Destination:=newRow
                dataSh.Range("A" & x & ":" & "G" & x).Copy Destination:=newRow.Offset(0, 8)

            End If
        
        Next
    
    Next

Separate_Groups

Set listSh = Nothing
Set dataSh = Nothing
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

Public Sub Separate_Groups()
Dim R As Long
Dim x As Long

Application.ScreenUpdating = False
     R = 2
     Do While Cells(R, "a") <> "" And R < Rows.Count
       If Cells(R, "a") <> Cells(R + 1, "a") Then
          Cells(R + 1, "a").EntireRow.Insert Shift:=xlShiftDown
          R = R + 2
       Else
          R = R + 1
       End If
     Loop
Application.ScreenUpdating = True
End Sub

Have you tried my code?

Hi downtown1933,
try it

Sub ertert()
Dim x, y, res(), i&, j&, k&, n&, sp
With Sheets("Sample LIST")
    x = .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
With Sheets("Sample DATA")
    y = .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
ReDim res(1 To UBound(x) * 10, 1 To 15)
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(x)
        If .Exists(x(i, 1)) Then
            .Item(x(i, 1)) = .Item(x(i, 1)) & " ~" & i
        Else
            .Item(x(i, 1)) = i
        End If
    Next i
    For i = 2 To UBound(y)
        If .Exists(y(i, 1)) Then
            sp = Split(.Item(y(i, 1)), "~")
            For j = 0 To UBound(sp)
                k = k + 1
                For n = 1 To UBound(x, 2)    'UBound(x, 2) = UBound(y, 2) !!!
                    res(k, n) = x(sp(j), n)
                    res(k, n + 8) = y(i, n)
                Next n
            Next j
        End If
    Next i
End With
With Sheets("Sample Results")
    .UsedRange.ClearContents
    With .Range("A1:O1").Resize(k)
        .Value = res()
        .Sort Key1:=.Cells(1, 1), Order1:=xlDescending, _
              Key2:=.Cells(1, 2), Order2:=xlDescending, _
              Key3:=.Cells(1, 10), Order3:=xlDescending
    End With
    .Activate
End With
End Sub

downtown1933,
My code works on a single row as per your description, but Nilem came up with a better and accurate code.

nilem & jindon, both codes worked perfectly on the sample data, but when tested on my actual data, Excel froze up and restarted itself... I cant seem to find anything that can handle processing that many rows!?

My actual data would be about the same as the sample data, only differences really being that the Actual ListSh has about 1700 Rows, and the Actual DataSh has about 7,000 Rows.. I know that in the end, when matched correctly there should be well over 100,000 on the results sheet... It just seems like anything i try brings my computer to its knees

downtows1933,
100k is a massive data, but I would not expect my PC to freeze. Yes, the code may take a couple of minutes to run, but not to freeze.
What is your memory gig?

Not sure how would i check?

Got a Type Mis Match Here:

n = n + UBound(.Item(a(i, 1)), 2) + 1

Are the data layouts the same?

The data should start from A1.

I got it running, but its been going for 9 minutes now un-responsive? Im not sure if it's frozen or still running?

Hi downtown1933,
could you upload your real file to the file sharing and show the link here?

downtown1933

This took 26.6250 sec for 25727 rows in Sample List.
So, it may take much longer if you have many rows in both sheets.

Option Explicit

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv, x
    Dim w, ub As Long, n As Long, t As Long, e
    Const myLimit As Long = 4000
    Application.ScreenUpdating = False
    Sheets("sample results").Cells.ClearContents
    a = Sheets("sample data").Cells(1).CurrentRegion.Value
    ub = UBound(a, 2): x = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: ReDim w(1 To UBound(a, 2))
        For i = UBound(a, 1) To 1 Step -1
            If Not .Exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 1)) = w
            t = Application.Max(t, UBound(w, 2) + 1)
        Next
        a = Sheets("sample list").Cells(1).CurrentRegion.Value
        For i = UBound(a, 1) To 1 Step -myLimit
            ReDim b(1 To myLimit * t, 1 To UBound(a, 2) + ub + 1)
            For ii = i To Application.Max(i - myLimit - 1, 1) Step -1
                If .Exists(a(ii, 1)) Then
                    For iii = 1 To UBound(.Item(a(ii, 1)), 2)
                        n = n + 1
                        For iv = 1 To UBound(a, 2)
                            b(n, iv) = a(ii, iv)
                        Next
                        For iv = 1 To UBound(.Item(a(ii, 1)), 1)
                            b(n, ub + iv + 1) = .Item(a(ii, 1))(iv, iii)
                        Next
                    Next
                End If
                n = n + 1
            Next
            Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b
            x = x + n + 1: n = 0
        Next
    End With
    Application.ScreenUpdating = True
    Sheets("sample results").Select
End Sub

26 Seconds!? Is it something I'm doing wrong? I tried running yours jindon first thing this morning.. It has been going for about 6 minutes now..Right now I've got about 1500-1600 rows in my list, and 5540 Rows in my Data.....


Ok so while I was writing this, it stopped running after about 6 1/2 minutes with an error on this line:
" Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b "

snb Yours ran pretty quick, but not quite everything was returned.

26 sec is made under

25272 rows in Sample list
39 rows in Sample Data
End up 172460 rows in result.

1500 * 5540 = 8310000 (maximum possibility)

It easily exceeds the row limit of 1048576.
Exceeds the row limits in Excel.

AB33, are you saying to just copy/paste as values before running? And just for future reference, why would pasting everything as values make a difference?

I think we are talking about different codes.

I'm running the code in my post #23
that is

Option Explicit

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv, x
    Dim w, ub As Long, n As Long, t As Long, e
    Const myLimit As Long = 4000
    Application.ScreenUpdating = False
    Sheets("sample results").Cells.ClearContents
    a = Sheets("sample data").Cells(1).CurrentRegion.Value
    ub = UBound(a, 2): x = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: ReDim w(1 To UBound(a, 2))
        For i = UBound(a, 1) To 1 Step -1
            If Not .Exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 1)) = w
            t = Application.Max(t, UBound(w, 2) + 1)
        Next
        a = Sheets("sample list").Cells(1).CurrentRegion.Value
        For i = UBound(a, 1) To 1 Step -myLimit
            ReDim b(1 To myLimit * t, 1 To UBound(a, 2) + ub + 1)
            For ii = i To Application.Max(i - myLimit - 1, 1) Step -1
                If .Exists(a(ii, 1)) Then
                    For iii = 1 To UBound(.Item(a(ii, 1)), 2)
                        n = n + 1
                        For iv = 1 To UBound(a, 2)
                            b(n, iv) = a(ii, iv)
                        Next
                        For iv = 1 To UBound(.Item(a(ii, 1)), 1)
                            b(n, ub + iv + 1) = .Item(a(ii, 1))(iv, iii)
                        Next
                    Next
                End If
                n = n + 1
            Next
            Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b
            x = x + n + 1: n = 0
        Next
    End With
    Application.ScreenUpdating = True
    Sheets("sample results").Select
End Sub

It looks like the error goes away if i remove all blanks, and remove all Col-A values that have letters & Numbers.. (ie: "API1000023456")
Would that make sense? Should the cell value have any impact on the results?

jindon,

To add to the mystery of this error i keep getting; I pasted a smaller sample of my data to your "book2 with code2" and ran it again. This time it executed perfectly, with no error?

Every time I run it, I remove any blank lines, and sort Col-A values from smallest to largest. The only variable which has changed here is that i used a smaller number of rows. Could it be the size?

I suspect your data are loaded from an application, such as SAP, or oracle. In other words, you data are not originally created in excel, rather they are exported in to excel from external application. If my assumption is right, even 20k rows will crash excel.
That is my experience any way. You need to convert these data in VALUES ONLY FIRST before you work on them.

jindon,
i tried your "book2 with code2" again. I added values to Column H in both sheets and it started running..
I still got the error in line 34 here: " n = n + UBound(.Item(a(i, 1)), 2) + 1 "

However, There were about 25000 rows that were still sent to the results sheet prior to the error?

Originally Posted by downtown1933

jindon,
i tried your "book2 with code2" again. I added values to Column H in both sheets and it started running..
I still got the error in line 34 here: " n = n + UBound(.Item(a(i, 1)), 2) + 1 "

However, There were about 25000 rows that were still sent to the results sheet prior to the error?

I have just tested the file with 25272 rows of data with Col.H added to both sheet.

It run without error.

Make sure data starts from A1 in both sheet.

I do not know the reason, perhaps more experience people can suggest possible reasons.
I was answering a thread, similar question to this. The OP had e-mailed me his spread sheet. He had about 20k rows, but when I run the code, it kept crashing my PC- Infact 3 times. I thought I lost my laptop. My laptop was making lots of noise when I run the code. My laptop is prey new. 8 Gig memory.

I copied the sheets and converted the data in VALUES ONLY, deleted the source sheet. Boy, the code run in 5 seconds.
I had similar other experience in this site after the first incidence.
If I run a code and PC starts to make noise, I know these data are imported one. This is just my experience in this site.
As I said, I have no idea what causes this behaviour, but I suspect these data may have unseen dirty data.

That's crazy because I have come across similar issues. I don't recall what exactly it was that I was trying to accomplish, but my PC has crashed while trying to run very simple code. I don't remember how big the file was, but I do remember the noises it made right before doing so...

Do you remember where your data came from before you put it in excel?

Originally Posted by jindon

Blanks are no good, but the "API1000023456" should not affect the result.

Need to see the actual data type anyway if possible.

P.S.
Past midnight, so I will see you tomorrow if any problem left.

Thanks jindon! There was some special character on the end of some of my Col-A values.. I took those out and it works Great. I also added a timer, With a list sheet containing about 1600 values, being matched to Data Sheet with about 6,000 values, it pulls almost 170,000 rows to results sheet, in 6.58 minutes. This is the code that did it courtesy of jindon:

Option Explicit

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv, x
    Dim w, ub As Long, n As Long, t As Long, e
    Const myLimit As Long = 4000
    Application.ScreenUpdating = False
    Sheets("sample results").Cells.ClearContents
    a = Sheets("sample data").Cells(1).CurrentRegion.Value
    ub = UBound(a, 2): x = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: ReDim w(1 To UBound(a, 2))
        For i = UBound(a, 1) To 1 Step -1
            If Not .Exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 1)) = w
            t = Application.Max(t, UBound(w, 2) + 1)
        Next
        a = Sheets("sample list").Cells(1).CurrentRegion.Value
        For i = UBound(a, 1) To 1 Step -myLimit
            ReDim b(1 To myLimit * t, 1 To UBound(a, 2) + ub + 1)
            For ii = i To Application.Max(i - myLimit - 1, 1) Step -1
                If .Exists(a(ii, 1)) Then
                    For iii = 1 To UBound(.Item(a(ii, 1)), 2)
                        n = n + 1
                        For iv = 1 To UBound(a, 2)
                            b(n, iv) = a(ii, iv)
                        Next
                        For iv = 1 To UBound(.Item(a(ii, 1)), 1)
                            b(n, ub + iv + 1) = .Item(a(ii, 1))(iv, iii)
                        Next
                    Next
                End If
                n = n + 1
            Next
            Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b
            x = x + n + 1: n = 0
        Next
    End With
    Application.ScreenUpdating = True
    Sheets("sample results").Select
End Sub

That's good to hear.

That's all I can do for you.

If the code solved your problem, please mark this thread as "Solved"

jindon, one more thing, would you mind commenting your code? I'm still a bit new to the Scripting.Dictionary and I want to understand what exactly you just did. Thanks again.

1)

    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: ReDim w(1 To UBound(a, 2))
        ' ---- Loop through the list in "Sample Data" from the bottom
        For i = UBound(a, 1) To 1 Step -1
            If Not .Exists(a(i, 1)) Then
                ' ---- If the data in col.A is unique,
                ' ---- initialize temproraly array in transposed format
                ' ---- since array can be resize only last dimension.
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                ' ---- If not unique, resize the array in that item by 1.
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                ' ---- store each data in the last dimension of the array
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 1)) = w
            ' ---- determine the maximum combination of one item
            t = Application.Max(t, UBound(w, 2) + 1)
        Next

2)

        ' ---- Loop through the list in "Sample List" from the bottom
        For i = UBound(a, 1) To 1 Step -myLimit
            ' Initialize the output array, b.
            ReDim b(1 To myLimit * t, 1 To UBound(a, 2) + ub + 1)
            ' ---- Loop each myLimit(4000) rows
            For ii = i To Application.Max(i - myLimit - 1, 1) Step -1
                ' ---- If col.A found in dictionary
                If .Exists(a(ii, 1)) Then
                    ' ---- Loop for number of rows that item has.
                       ' ---- i.e.UBound(.Item(a(ii, 1)), 2)
                    For iii = 1 To UBound(.Item(a(ii, 1)), 2)
                        n = n + 1  '<---- Increase the counter
                        ' ---- Store data in list in first columns of output array
                        For iv = 1 To UBound(a, 2)
                            b(n, iv) = a(ii, iv)
                        Next
                        For iv = 1 To UBound(.Item(a(ii, 1)), 1)
                            ' ---- Store the data in dictionary to corresponding cols.
                            b(n, ub + iv + 1) = .Item(a(ii, 1))(iv, iii)
                        Next
                    Next
                End If
                n = n + 1  '< ---- create a gap for each item
            Next
            ' ---- Dump the processed result for each 4000 rows of data
            Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b
            x = x + n + 1: n = 0 '< ---- Initialize the counter for next 4000
        Next

Help?