匹配字典并创建新的 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

Answer 2

这里有一个稍微不同的方法

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