在两个打开的Excel中复制匹配列值的宏脚本

Question

我有一个宏脚本来识别两个打开的excel中的匹配列值（第一列中的列A和第二列中的列A）。我需要匹配的列值被复制到列A中的新Excel（第三Excel）。请指导我。

Sub Compare() 

Dim wb1 As Workbook 
Dim wb2 As Workbook 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim Cell As Range 
Dim sBook As String 

If Workbooks.Count < 2 Then 
    MsgBox "Error: Only one Workbook is open" & vbCr & _ 
"Open a 2nd Workbook and run this macro again." 
    Exit Sub 
End If 

Set wb1 = ThisWorkbook 
For Each wb2 In Workbooks 
If wb2.Name <> wb1.Name Then Exit For 
Next 

On Error Resume Next 
ReDo1: 
Application.DisplayAlerts = False 
sBook = Application.InputBox(Prompt:= _ 
"Compare this workbook (" & wb1.Name & _ 
") to...?", _ 
Title:="Compare to what workbook?", _ 
Default:=wb2.Name, _ 
Type:=2) 
If sBook = "False" Then Exit Sub 
    If Workbooks(sBook) Is Nothing Then 
    MsgBox "Workbook: " & sBook & " is not open." 
    GoTo ReDo1 
    Else 
    Set wb2 = Workbooks(sBook) 
    End If 

    Application.ScreenUpdating = False 
For Each ws1 In wb1.Sheets 
If Not wb2.Sheets(ws1.Name) Is Nothing Then 
    Set ws2 = wb2.Sheets(ws1.Name) 
    For Each Cell In ws1.UsedRange 
    If Cell.Formula = ws2.Range(Cell.Address).Formula Then 
     Cell.Interior.ColorIndex = 35 
     ws2.Range(Cell.Address). _ 
     Interior.ColorIndex = 35 
    End If 
    Next Cell 
    If ws1.UsedRange.Rows.Count = _ 
    ws2.UsedRange.Rows.Count Or _ 
    ws1.UsedRange.Columns.Count = _ 
    ws2.UsedRange.Columns.Count Then 
    For Each Cell In ws2.UsedRange 
    If Cell.Formula = ws1.Range(Cell.Address).Formula Then 
    Cell.Interior.ColorIndex = 35 
    ws1.Range(Cell.Address). _ 
    Interior.ColorIndex = 35 
    End If 
    Next Cell 
    End If 
    End If 
    Next ws1 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    End Sub 

Answer 1

你的VBA真的很棒，让你非常接近。我会建议添加这些变量。

Dim wb3 As Workbook 
Dim wb3cell As Range 

从那里，第一行打开一个新的工作簿并将其分配给wb3。您还希望为wb3中的单元格A1分配范围变量以将结果发送到。

Set wb3 = Workbooks.Add 
Set wb3cell = wb3.Sheets(1).Range("A1") 

您的线路ws2.Range（Cell.Address）.Interior.ColorIndex = 35后，这些接下来的2行转移匹配到WB3。你已经发现它改变了背景，所以当时发送这个值到wb3是最有效的。

wb3cell.Value = Cell.Value 
Set wb3cell = wb3cell.Offset(1, 0) 

这最后一点代码是你的，我发现它找到了与上面的循环相同的结果。也许它应该被删除或者改变如果到elseif的与您如果不wb2.Sheets匹配（ws1.Name）是没有那么线或者也许是罚款事情是这样的。我只提到它，因为它给了我重复的结果，但那可能只是我创建的“播放数据”。

If ws1.UsedRange.Rows.count = ws2.UsedRange.Rows.count Or _ 
ws1.UsedRange.Columns.count = ws2.UsedRange.Columns.count Then 
    For Each Cell In ws2.UsedRange 
     If Cell.Formula = ws1.Range(Cell.Address).Formula Then 
      Cell.Interior.ColorIndex = 35 
      ws1.Range(Cell.Address).Interior.ColorIndex = 35 
      wb3cell.Value = Cell.Value 
      Set wb3cell = wb3cell.Offset(1, 0) 
     End If 
    Next Cell 
End If