Looping through multiple sheets at once - excel

Question

I am trying to run through a column and get the value in the cell. The value is a unique code and only appears once on the first sheet.
When i get a value, it could be the first cell, i want to go through a column in sheet 4. The unique code can appear multiple times on sheet 4.
I want to match the code from sheet one with the code from sheet 4. If the codes are matching, i want to save the colum value on the row index and insert it into a completely new workbook.
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
Const WB_OUTPUT = "MyResult.xlsx"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, sKey As String, ar As Variant
Set dict = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Dim Pheight As Integer
Pheight = 25000
Set WkSht_Src = ThisWorkbook.Worksheets(2)
Set Rng = WkSht_Src.Range(ThisWorkbook.Worksheets(2).Cells(1, 1), ThisWorkbook.Worksheets(2).Cells(Pheight, 48))
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
Rng.Copy
WkSht_Dest.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
WkSht_Dest.Range("A1").PasteSpecial
WkSht_Dest.Pictures(1).Top = 5
WkSht_Dest.Pictures(1).Left = 0
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
count = count + 1
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
MsgBox dict.count & " keys in dictionary ", vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''

Answer 1

Use a Dictionary Object not a loop in a loop.
Sub exportSheet2()
Const START_ROW = 11
Const MAX_ROW = 40
Const CODE_SHT1 = "C"
Const CODE_SHT4 = "E"
Const CVR_SHT4 = "C"
Const CVR_SHT3 = "C"
' sheet 4 columns
'C - Employer CVR MD
'D - Employer name
'E - broker code
'F - Broker name
'? Employer CVR CER
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, wsNew As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionExceptionReport")
Set ws4 = wb.Sheets("MasterData")
Dim dict As Object, dictCVR As Object, sKey As String, ar As Variant
Dim sCVR As String, arCVR As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictCVR = CreateObject("Scripting.Dictionary")
' build dictionary from sheet4 of code to rows number
iLastRow = ws4.Cells(Rows.count, CODE_SHT4).End(xlUp).Row
For iRow = 13 To iLastRow
sKey = ws4.Cells(iRow, CODE_SHT4)
If dict.exists(sKey) Then
dict(sKey) = dict(sKey) & ";" & iRow ' matched row on sheet 1
Else
dict(sKey) = iRow
End If
Next
' build dictCVR from sheet3
iLastRow = ws3.Cells(Rows.count, CVR_SHT3).End(xlUp).Row
For iRow = 18 To iLastRow
sKey = ws3.Cells(iRow, CVR_SHT3)
If dictCVR.exists(sKey) Then
dictCVR(sKey) = dictCVR(sKey) & ";" & iRow
Else
dictCVR(sKey) = iRow
End If
Next
' scan down sheet1
count = 0: countWB = 0
iRow = START_ROW
Do Until (ws1.Cells(iRow, CODE_SHT1) = "END") Or (iRow > MAX_ROW)
sKey = ws1.Cells(iRow, CODE_SHT1)
If dict.exists(sKey) Then
' rows on sheet4 to copy
ar = Split(dict(sKey), ";")
'create new workbook and copy rows
Set WkSht_Src = wb.Worksheets(2)
Set Rng = WkSht_Src.Range("A1:AV25000")
Set WkBk_Dest = Application.Workbooks.Add
Set WkSht_Dest = WkBk_Dest.Worksheets(1)
With WkSht_Dest
Rng.Copy
.Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
.Range("A1").PasteSpecial xlPasteFormats
WkSht_Src.Pictures(1).Copy
.Range("A1").PasteSpecial
.Pictures(1).Top = 5
.Pictures(1).Left = 0
End With
Application.CutCopyMode = False
iTargetRow = 11
Set wsNew = WkSht_Dest
Set wbNew = WkBk_Dest
For i = LBound(ar) To UBound(ar)
iCopyRow = ar(i)
iTargetRow = iTargetRow + 1
' copy selected cols to new workbook
ws4.Range("C" & iCopyRow).Resize(1, 5).Copy wsNew.Range("A" & iTargetRow)
' add cvr records from sheet3 it any
sCVR = ws4.Cells(iCopyRow, CVR_SHT4)
If dictCVR.exists(sCVR) Then
arCVR = Split(dictCVR(sCVR), ";")
For j = LBound(arCVR) To UBound(arCVR)
If j > 0 Then iTargetRow = iTargetRow + 1
' copy col A to P
iCopyRow = arCVR(j)
Debug.Print sCVR, j, iCopyRow
ws3.Range("A" & iCopyRow).Resize(1, 16).Copy wsNew.Range("E" & iTargetRow)
count = count + 1
Next
Else
count = count + 1
End If
Next
wbNew.SaveAs sKey & ".xlsx"
wbNew.Close
countWB = countWB + 1
End If
iRow = iRow + 1
Loop
msg = dict.count & " keys in CODE dictionary" & vbCr & _
dictCVR.count & " keys in CVR dictionary"
MsgBox msg, vbInformation
msg = iLastRow & " rows scanned on sheet4 " & vbCr & _
count & " rows copied to " & countWB & " new workbooks"
MsgBox msg, vbInformation
End Sub '''