VBA Loop through cells in another sheet

[reddsable]

Hello, I have the below code that I would like to improve and make it work faster.

The idea is that first it's looking in my Sheet "Master", to see if the value in cell B1 from Sheet "Files", is found in column B of "Master". If it is found, then copy all the rows in Sheet2 and then in another sheet I am copying the value from Sheet2. Then it should look for B2 , copy the row in Sheet2 if the value from B2 is found in "Master", then look for B3 and so on. Any idea how I could loop this search? I tried with If InStr(rngCell, Sheets("Files").Cells(i,2).Value) > 0 Then, it's working but at the last loop it's copying all my table from "Master" to "Sheet2".

Sheets("Sheet2").Cells.Clear
    Sheets("Path").Activate
    Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
    For Each rngCell In Sheets("Master").Range("B1:B" & Sheets("Master").Range("B" & Rows.Count).End(xlUp).Row)
        If InStr(rngCell, Sheets("Files").Range("B1").Value) > 0 Then
            If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "D"))) Then
                lngMyArrayCounter = lngMyArrayCounter + 1
                objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "D"))), lngMyArrayCounter
                varMyItem = Sheets("Path").Cells(rngCell.Row, "D")
                For lngMyRow = 1 To Sheets("Path").Cells(Rows.Count, "D").End(xlUp).Row
                    If Sheets("Path").Cells(lngMyRow, "D") = varMyItem Then
                        Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
                    End If
                Next lngMyRow
            End If
        End If
    Next rngCell
    
    Sheets("Sheet1").Activate
    ActiveCell.Formula = "=Sheet2!R2C4"
    ur = findlastrow(Sheets("Files"))
    Selection.Offset(ur, 0).Select
    ActiveCell.Formula = "=Sheet2!R3C4"
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Range("B" & Rows.Count).End(xlUp).Select
    
    
    Sheets("Sheet2").Cells.Clear
    Sheets("Path").Activate
    Set objMyUniqueArray = CreateObject("Scripting.Dictionary")
    For Each rngCell In Sheets("Master").Range("B1:B" & Sheets("Master").Range("B" & Rows.Count).End(xlUp).Row)
        If InStr(rngCell, Sheets("Files").Range("B2").Value) > 0 Then
            If Not objMyUniqueArray.Exists(Trim(Cells(rngCell.Row, "D"))) Then
                lngMyArrayCounter = lngMyArrayCounter + 1
                objMyUniqueArray.Add (Trim(Cells(rngCell.Row, "D"))), lngMyArrayCounter
                varMyItem = Sheets("Path").Cells(rngCell.Row, "D")
                For lngMyRow = 1 To Sheets("Path").Cells(Rows.Count, "D").End(xlUp).Row
                    If Sheets("Path").Cells(lngMyRow, "D") = varMyItem Then
                        Rows(lngMyRow).Copy Destination:=Sheets("Sheet2").Range("A" & Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1)
                    End If
                Next lngMyRow
            End If
        End If
    Next rngCell
    
    Sheets("Sheet1").Activate
    ur = findlastrow(Sheets("Files"))
    Selection.Offset(-ur + 1, 0).Select
    ActiveCell.Formula = "=Sheet2!R2C4"
    ur = findlastrow(Sheets("Files"))
    Selection.Offset(ur, 0).Select
    ActiveCell.Formula = "=Sheet2!R3C4"
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        Range("B" & Rows.Count).End(xlUp).Select

 

[sijpie]

Hi redsable,

I haven't gone through your code in detail, but there are for starters a few things that can speed up your code and make it a lot more efficient.
In the first part you set up a dictionary where you essentially will add all the items in the Master sheet. A dictionary is highly efficient in looking things up. so far so good.
But then when you have done the checking of the cell B1, you throw out this dictionary and start building it up again!

THen the way (I understand) you are trying to make your code, is that you repeat this code for each line. Why? This should be in a loop. That means you write the piece of code only once. If something needs changing you only need to change it once. And it will be totally independent of the number of rows to be processed.

What makes code run slow? Writing to the sheet, reading from the sheet to a lesser degree, doing lengthy things inside a loop, having too many variables.
Writing to the sheet: THis is a slow process. Writing 1000 cells in one go hardly takes more time than writing just one cell. But writing 1000 cells in a loop, one by one takes 'ages'.
Reading from a cell: This is a lot faster than writing, but the same goes: when reading try to read a whole block at once: use arrays to store these
doing too much in a loop: efficient code tries to keep the loop lean and mean. Sometimes some stuff can be done before or after the loop and does not need to be repeated.
Too many variables: Say you want to read a cell (I told you not to!) in a loop. You address it as Sheet("Master").Range("B" & lCounter). You need to read it twice in the loop. That means that 3 variables need to be called each time to put the address together inside an object. If the value was copied to a variable at the start, then only the one variable needs to be called.

OK. Now to your code:

Working with arrays is nearly as fast as working with dictionaries.
In order to add all the cells in a dictionary you would have to either
loop through each cell (slow!!)
or read all the cells into an array, and then loop through the array (fast)

But if you already have read the cells into an array, there really is no extra incentive to add them to a dictionary.

So what is an array?
An array (2D) is like a sheet: it has rows and columns.

The following code will read the Mastersheet data into an array (assuming that your table starts in A1):

    dim vArrayMaster as Variant

    vArrayMaster = Sheets("Master").Range("A1").CurrentRegion.Value

vArrayMaster(2,5) will now hold the same value as cell E2 in the master sheet.

So now you can loop through the B column of Master starting from B2 by reading from the array:

    dim lRmstr as long
        
    for lRmstr = 2 to Ubound(vArrayMaster,1)
        if vArrayMaster(lrmstr,2) = x then do something
    next lRmstr

What is this Ubound() function? It gets the upper bound of an array. Because Ubound(Array,1) is used it gets the upper bound( the size) of the first dimension, which holds the rows in this case. So the snippet will run from the second row to the last row.

Of course you don't want to then spoil the speed by starting to read each cell from the sheet "Files". You want tor read that sheet into an array as well, and then just loop through the two arrays.

something like:

    dim vMaster as Variant, vFiles as Variant, vOut as variant
    dim lRmstr as long, lRfls as long, lRout as long, lC as long, lUB2 as long

    vMaster = Sheets("Master").Range("A1").CurrentRegion.Value
    vFiles = Sheets("Files").Range("A1").CurrentRegion.Value
    lUB2 = Ubound(vFiles,2)   'number of columns in Files

    redim vOut(1 to Ubound(vMaster,1), 1 to lUB2  ' output array same number of rows as Master, same number of columns as Files
    lRout=1
    for lRfls = 2 to Ubound(vFiles,1)      'loop through each row in Files array
        for lRmstr = 2 to Ubound(vMaster,1)     'loop through each row in Master array to check if value exists
            if vMaster(lRmstr,2) = vFiles(lRfls,2) then 
                for lC = 1 to UB2    'copy the row from Files array to output array
                    vOut(lRout,lC)=vFiles(lRfls(lRfls, lC)
                next lC
                lRout = lRout + 1   'increment row counter for output array
          end if
        next lRmstr    
   next lRfls

  'now dump the output array to the sheet
  Sheets("Sheet2").Range("A1").Resize(Ubound(vOut,1),lUB2).Value = vOut

Soemthing like that should work. Two reads, One write. Blindingly fast

THis code is not tested