Question

我有一个宏脚本来识别两个打开的Excel中的匹配列值（第一个excel中的列A和第二个excel中的列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。您还想将 Range 变量分配给wb3中的单元格A1以将结果发送到。

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

在您的行 ws2.Range（Cell.Address）.Interior.ColorIndex = 35 之后，接下来的两行将匹配转移到wb3。您已经发现它可以更改背景，因此在那时将该值发送到wb3效率最高。

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

这最后一段代码是你的，我注意到它找到了与上面的循环相同的结果。也许它应该从 If 删除或更改为 ElseIf 以匹配您的如果不是wb2.Sheets（ws1.Name）则没有那么这条线或者说它的方式很好。我只提到它，因为它给了我重复的结果，但这可能只是＆＃34;播放数据＆＃34;我创造了这样做。

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

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

1 个答案: