我有2个工作簿,工作簿A和工作簿B.每个工作簿都有一个表。工作簿A有2列。所有三列都已填满。
工作簿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的其余机器编号会相应地被复制和粘贴。
这些是结果的屏幕截图
第一个截图是 练习册B
第二个截图是 练习册A
我不知道为什么会这样,有人可以告诉我这个原因吗?
............................................... ................................. 的更新
我发现,当product_id(style_number)重复时,问题中描述的问题就出现了。
说两个工作簿中的2个单元格中是否存在product_id GE 55950。然后当我执行宏时,仅检测到一个单元。
我在两个答案中都尝试了编码,但都没有解决这个问题。
以下是结果的屏幕截图。
在屏幕截图中,未显示带有机器7的单元格。有人能告诉我为什么会这样吗?
答案 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
输出结果
答案 1 :(得分:1)
我试图复制你的工作簿,我相信它们就是这样的
在 后
代码更改很小,
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