在兩個打開的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