Подбор словарей и создание нового wb

Question

У меня есть два листа, на которых я хочу сравнить «код», отображаемый в первом столбце обоих листов.

Это лист1: Лист1

это лист2: лист2

Я хочу go просмотреть каждый код на листе 1 и найти все строки на листе 2 с одинаковым кодом и вставить строку (из листа2) в новый wb.

Вот как я создаю словари.

iLastRow = ws1.Cells(Rows.Count, 3).End(xlUp).Row
For iRow = 18 To iLastRow
    sKey = ws1.Cells(iRow, 3)
    If Dict.Exists(sKey) Then
        Dict(sKey) = Dict(sKey) & ";" & iRow ' matched row on sheet 1
    Else
        Dict(sKey) = iRow
    End If
    Debug.Print ((sKey))
Next

Debug.Print ("These are the values in dictionary2")
'' Dictionary broker code sheet 2
iLastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
For iRow = 2 To iLastRow
    sBROKER = ws2.Cells(iRow, 1)
    If Dict.Exists(sBROKER) Then
        dictBROKER(sBROKER) = dictBROKER(sKey) & ";" & iRow ' matched row on sheet 1
    Else
        dictBROKER(sBROKER) = iRow
    End If
    Debug.Print ((sBROKER))
Next

часть отладочной печати: debug.print

Надеюсь, кто-то сможет помогите мне

Answer 1

Вот немного другой подход

Sub CopyToNewWorkbook()

    Dim oMasterWS As Worksheet: Set oMasterWS = Sheet3        '<- Change to the sheet that has the codes
    Dim oDataWS As Worksheet: Set oDataWS = Sheet4            '<- Change to sheet where you want to copy row from
    Dim oNewWB As Workbook
    Dim iTRMWS As Long: iTRMWS = oMasterWS.Range("A" & oMasterWS.Rows.Count).End(xlUp).Row
    Dim iTRDWS As Long
    Dim iC As Long
    Dim oFilterRng As Range
    
    With oDataWS
        
        ' Get Data sheet row count
        If .AutoFilterMode Then .AutoFilterMode = False
        iTRDWS = .Range("A" & .Rows.Count).End(xlUp).Row
        
        ' Loop through all values in Master sheet
        For iC = 2 To iTRMWS
            
            ' Set filter on Data sheet based on the value from Master sheet
            .Range("A1").AutoFilter Field:=1, Criteria1:=oMasterWS.Range("A" & iC).Value
            
            ' Set filtered range
            Set oFilterRng = Nothing
            On Error Resume Next
            Set oFilterRng = .Range("A2:A" & iTRDWS).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            
            ' If filtered range is found, copy it to a new workbook
            If Not oFilterRng Is Nothing Then
                Set oNewWB = Workbooks.Add
                oFilterRng.EntireRow.Copy oNewWB.Sheets(1).Range("A1")
                oNewWB.SaveAs ThisWorkbook.Path & "\" & oMasterWS.Range("A" & iC).Value
                oNewWB.Close savechanges:=False
            End If
            
            ' Clear filter
            If .AutoFilterMode Then .AutoFilterMode = False
        
        Next
        
    End With
    
End Sub

Answer 2

Попробуйте следующий код, пожалуйста:

Sub copyToNewSheets()
 Dim ws1 As Worksheet, ws2 As Worksheet, rngC As Range, skey As String
 Dim i As Long, j As Long, lastCol As Long, iLastRow, jLastRow As Long
 Dim Wb As Workbook, wsNew As Worksheet, k As Long, rngHeader As Range

 Set ws1 = ActiveSheet               'use here your sheet
 Set ws2 = Worksheets("SecondSheet") 'use here your sheet, too
 iLastRow = ws1.cells(Rows.count, 3).End(xlUp).Row
 jLastRow = ws2.cells(Rows.count, 3).End(xlUp).Row
 Set rngHeader = ws2.Range("A1:E1")

 'Create the new workbook
 Set Wb = Workbooks.Add
 For i = 1 To Wb.Worksheets.count - 1
    Application.DisplayAlerts = False
       Wb.Sheets(i).Delete
    Application.DisplayAlerts = True
 Next i
 
  'for making the code faster:_________________
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  '____________________________________________
  
  lastCol = 5: k = 1
  For i = 18 To iLastRow
    skey = ws1.cells(i, 3).Value
    For j = 2 To jLastRow
        If skey = ws2.Range("A" & j).Value Then
            If rngC Is Nothing Then
                Set rngC = ws2.Range(ws2.Range("A" & j), ws2.cells(j, lastCol))
            Else
                Set rngC = Union(rngC, ws2.Range(ws2.Range("A" & j), ws2.cells(j, lastCol)))
            End If
        End If
    Next j
    If Not rngC Is Nothing Then
        If k = 1 Then
            Set wsNew = Wb.Sheets(k): k = k + 1
        Else
            Set wsNew = Wb.Sheets.Add(After:=Wb.Sheets(k - 1)): k = k + 1
            
        End If
        wsNew.Name = skey
        rngHeader.Copy Destination:=wsNew.Range("A1")
        rngC.Copy Destination:=wsNew.Range("A2")
        Set rngC = Nothing
   End If
 Next i
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  MsgBox "Ready...", vbInformation
End Sub