时间戳

首页 > 解决方案 > Excel VBA匹配两个不同工作簿中两列的行数据并复制数据

excel - Excel VBA匹配两个不同工作簿中两列的行数据并复制数据

问题描述

我有两个不同的工作簿，wb1 和 wb2。我需要一个 VBA 脚本，它将匹配每个工作簿中两列的行数据，然后将偏移单元格从 wb2 复制到 wb1，循环遍历每一行的整个工作簿。我发现这篇文章非常接近，但是它不会将两列中的数据视为要匹配的单个数据。如果不先将列合并到单个单元格中，这可能吗？任何帮助将不胜感激。

我需要的样本 我需要的样本

我需要什么的清晰图片 我需要什么的清晰图片

这是我从引用的帖子中修改的代码，许多项目都被注释掉了，因为我一直在努力让它工作和故障排除。

Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range
Dim FR As Variant '<-- use Variant to allow catching a Error value
Dim ws1Range As Range, ws2Range As Range

Set w1 = Workbooks("Job Number with Labor Code.xlsx").Worksheets("LaborData")
Set w2 = Workbooks("Labor Report Project Hours.xlsx").Worksheets("Sheet1")
Set ws1Range1a = w1a.Range("C4", w1.Range("C" & w1.Rows.Count).End(xlUp))
Set ws1Range1b = w1b.Range("D4", w1.Range("D" & w1.Rows.Count).End(xlUp))
Set ws2Range = w2.Range("A8", w2.Range("B" & w1.Rows.Count).End(xlUp))

'w1.Activate
'ws1Range.Select
'w2.Activate
'ws2Range.Select

For Each c In ws1Range
MsgBox (c.Value)
    FR = Application.Match(c.Value, ws2Range, 0)
    If Not IsError(FR) Then
      'MsgBox (c.Value)

'        ' To copy formula and format
'        'ws1Range.Cells(FR, 2).Resize(, 2).Copy Destination:=c.Cells(1, 2).Resize(, 2)
            
'        ' to copy only values
'        'c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)
         'c.Cells.Select

'        ' To copy values and format
'        c.Cells(1, 2).Resize(, 2) = ws1Range.Cells(FR, 2).Resize(, 2)
'        ws1Range.Cells(FR, 2).Resize(, 2).Copy
'        c.Cells(1, 2).Resize(, 2).PasteSpecial Paste:=xlPasteFormats
    End If
Next c

标签： excelvba

解决方案

使用字典对象作为带有复合键的查找。

Option Explic
Sub macro1()

    Dim w1 As Worksheet, w2 As Worksheet
    Dim iLastRow As Long, r As Long
    Dim dict As Object, key As String, ar
    Set dict = CreateObject("Scripting.Dictionary")

    ' build lookup from sheet2
    Set w2 = Workbooks("Labor Report Project Hours.xlsx").Worksheets("Sheet1")
    iLastRow = w2.Cells(Rows.Count, "A").End(xlUp).Row
    ar = w2.Range("A1:C" & iLastRow).Value2
    
    For r = 8 To UBound(ar)
        key = ar(r, 1) & vbTab & ar(r, 2)
        If Len(key) > 1 Then ' skip blanks
            If dict.exists(key) Then
                MsgBox "Duplicate key '" & key & "'", vbCritical, "Row " & r
                Exit Sub
            Else
                dict.Add key, ar(r, 3)
            End If
        End If
    Next

    ' update sheet1
    Set w1 = Workbooks("Job Number with Labor Code.xlsx").Worksheets("LaborData")
    iLastRow = w1.Cells(Rows.Count, "C").End(xlUp).Row
    For r = 4 To iLastRow
        key = w1.Cells(r, "C") & vbTab & w1.Cells(r, "D")
        If dict.exists(key) Then
            w1.Cells(r, "F") = dict(key)
        End If
    Next
    MsgBox "Ended"
    
End Sub

推荐阅读