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".
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".
VBA Code:
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