excel - 匹配字典并创建新的 wb

Question

我有两张纸，我想比较出现在两张纸的第一列中的“代码”。
这是sheet1:
Sheet1
这是 sheet2:sheet2
我想遍历 sheet1 上的每个代码并找到 sheet 2 上具有相同代码的所有行，并将行(来自 sheet2)插入到新的 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 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