Цикл по нескольким листам одновременно

Question

Я пытаюсь пробежать столбец и получить значение в ячейке. Значение является уникальным кодом и отображается только один раз на первом листе.

Когда я получаю значение, это может быть первая ячейка, я хочу go через столбец на листе 4. Уникальный код может появиться несколько раз на листе 4.

Я хочу сопоставить код с листа один с кодом с листа 4. Если коды совпадают, я хочу сохранить значение столбца в индексе строки и вставить его в совершенно новую рабочую книгу.

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

Используйте Объект словаря , а не oop в al oop.

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 '''