excel vba宏来匹配来自两个不同工作簿的单元格并相应地进行复制和粘贴

时间:2015-02-28 10:35:39

标签: excel vba excel-vba excel-2010

我有2个工作簿,工作簿A和工作簿B.每个工作簿都有一个表。工作簿A有2列。所有三列都已填满。

  1. PRODUCT_ID
  2. Machine_number和
  3. 工作簿B具有相同的2列,但只填充了一列Product_id。另一列是空的。

    我需要匹配两个工作簿的product_id单元格。如果工作簿A中找到的product_id与工作簿B匹配,则应将该产品ID的计算机编号从工作簿A复制到工作簿B.

    我使用此代码执行了此操作:

    Sub UpdateW2()
    
    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Long
    
    Application.ScreenUpdating = False
    
    Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")
    
    
    For Each c In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
      FR = 0
      On Error Resume Next
      FR = Application.Match(c, w2.Columns("A"), 0)
      On Error GoTo 0
      If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, 0)
    Next c
    Application.ScreenUpdating = True
    End Sub
    

    有一个小区说'#34;机器4&#34;在产品编号栏中。此单元格不会与工作簿B中相应的product_id值一起复制和粘贴。

    产品ID的其余机器编号会相应地被复制和粘贴。

    这些是结果的屏幕截图 enter image description here enter image description here

    第一个截图是 练习册B

    第二个截图是 练习册A

    我不知道为什么会这样,有人可以告诉我这个原因吗?

    ............................................... ................................. 的更新

    我发现,当product_id(style_number)重复时,问题中描述的问题就出现了。

    说两个工作簿中的2个单元格中是否存在product_id GE 55950。然后当我执行宏时,仅检测到一个单元。

    我在两个答案中都尝试了编码,但都没有解决这个问题。

    以下是结果的屏幕截图。 enter image description here enter image description here

    在屏幕截图中,未显示带有机器7的单元格。有人能告诉我为什么会这样吗?

2 个答案:

答案 0 :(得分:2)

试试这个

Sub UpdateW2()
    Dim Dic As Object, key As Variant, oCell As Range, i&
    Dim w1 As Worksheet, w2 As Worksheet

    Set Dic = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workbookA.xlsm").Sheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Sheets("Sheet1")

    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w1.Range("D2:D" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, -3).Value
        End If
    Next

    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w2.Range("A2:A" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 2).Value = Dic(key)
            End If
        Next
    Next
End Sub

更新新要求

使用此

Sub UpdateW2()
    Dim key As Variant, oCell As Range, i&, z%
    Dim w1 As Worksheet, w2 As Worksheet
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dim Dic2 As Object: Set Dic2 = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workbookA.xlsm").Sheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Sheets("Sheet1")
    '-------------------------------------------------------------------------
    'get the last row for w1
    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row
    '-------------------------------------------------------------------------
    ' fill dictionary with data for searching
    For Each oCell In w1.Range("D2:D" & i)
        'row number for duplicates
        z = 1: While Dic.exists(oCell.Value & "_" & z): z = z + 1: Wend
        'add data with row number to dictionary
        If Not Dic.exists(oCell.Value & "_" & z) Then
            Dic.Add oCell.Value & "_" & z, oCell.Offset(, -3).Value
        End If
    Next
    '-------------------------------------------------------------------------
    'get the last row for w2
    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row
    '-------------------------------------------------------------------------
    'fill "B" with results
    For Each oCell In w2.Range("A2:A" & i)
        'determinate row number for duplicated values
        z = 1: While Dic2.exists(oCell.Value & "_" & z): z = z + 1: Wend
        'search
        For Each key In Dic
            If oCell.Value & "_" & z = key Then
                oCell.Offset(, 2).Value = Dic(key)
            End If
        Next
        'correction of the dictionary in case
        'when sheet "A" has less duplicates than sheet "B"
        If oCell.Offset(, 2).Value = "" Then
            Dic2.RemoveAll: z = 1
            For Each key In Dic
                If oCell.Value & "_" & z = key Then
                    oCell.Offset(, 2).Value = Dic(key)
                End If
            Next
        End If
        'add to dictionary already passed results for
        'the next duplicates testing
        If Not Dic2.exists(oCell.Value & "_" & z) Then
            Dic2.Add oCell.Value & "_" & z, ""
        End If
    Next
End Sub

输出结果

enter image description here

答案 1 :(得分:1)

我试图复制你的工作簿,我相信它们就是这样的

Before ClickAfter Click

代码更改很小,

Sub UpdateW2()

    Dim w1 As Worksheet, w2 As Worksheet
    Dim c As Range, FR As Long

    Application.ScreenUpdating = False

    Set w1 = Workbooks("BookOne.xlsm").Worksheets("Sheet1")
    Set w2 = Workbooks("BookTwo.xlsm").Worksheets("Sheet1")


    For Each c In w1.Range("D2", w1.Range("D" & Rows.Count).End(xlUp))
        FR = 0
        On Error Resume Next
        FR = Application.Match(c, w2.Columns("A"), 0)
        On Error GoTo 0
        If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, -3)
    Next c
    Application.ScreenUpdating = True
End Sub