excel vba 宏匹配来自两个不同工作簿的单元格并相应地复制和粘贴
excel vba macro to match cells from two different workbooks and copy and paste accordingly
我有2个作业本,作业本A和作业本B。每个作业本都有一个table。工作簿 A 有 2 列。所有三列都已填满。
- product_id
- Machine_number 和
工作簿 B 具有相同的 2 列,但只有一列 Product_id 已填充。其他 1 列是空的。
我需要匹配两个工作簿的 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
产品编号列中有一个单元格显示 "machine 4"。此单元格不会被复制并粘贴到工作簿 B 中相应的 product_id 值旁边。
相应地复制并粘贴产品 ID 的其余机器编号。
这些是结果的截图
第一张截图是
工作簿 B
第二个截图是
工作簿 A
我不知道为什么会这样,有人能告诉我这是什么原因吗?
................................................ ...................................................
更新
我发现当 product_id(style_number) 重复时,我在问题中描述的问题就会出现。
假设 product_id GE 55950 存在于两个工作簿的 2 个单元格中。然后当我执行宏时,只检测到一个单元格。
我尝试了两个答案中的编码,但都没有解决这个问题。
下面是结果的截图。
屏幕截图中没有显示机器 7 的单元格。谁能告诉我为什么会这样?
试试这个
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
输出结果如下
我试过复制你的练习册,我相信它们是这样的
之前
后
代码更改很小,
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
我有2个作业本,作业本A和作业本B。每个作业本都有一个table。工作簿 A 有 2 列。所有三列都已填满。
- product_id
- Machine_number 和
工作簿 B 具有相同的 2 列,但只有一列 Product_id 已填充。其他 1 列是空的。
我需要匹配两个工作簿的 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
产品编号列中有一个单元格显示 "machine 4"。此单元格不会被复制并粘贴到工作簿 B 中相应的 product_id 值旁边。
相应地复制并粘贴产品 ID 的其余机器编号。
这些是结果的截图
第一张截图是 工作簿 B
第二个截图是 工作簿 A
我不知道为什么会这样,有人能告诉我这是什么原因吗?
................................................ ................................................... 更新
我发现当 product_id(style_number) 重复时,我在问题中描述的问题就会出现。
假设 product_id GE 55950 存在于两个工作簿的 2 个单元格中。然后当我执行宏时,只检测到一个单元格。
我尝试了两个答案中的编码,但都没有解决这个问题。
下面是结果的截图。
屏幕截图中没有显示机器 7 的单元格。谁能告诉我为什么会这样?
试试这个
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
输出结果如下
我试过复制你的练习册,我相信它们是这样的
之前
代码更改很小,
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