Excel宏可根据特定的匹配条件将数据从一张纸复制到另一张纸 [英] Excel macro to copy data from one sheet to another based on specific matching conditions
问题描述
我有两张纸，其中一张包含所有匹配代码(主纸)的数据，另一张仅包含一些匹配某些代码的数据.这些代码链接到我需要从主表"输入到另一个表的数据号(以及其他值).我最初使用索引匹配来获取值和数据编号，但是很遗憾，我没有注意到有重复的匹配代码对应于不同的值和数据编号，因此我希望能够将所有数据复制粘贴到以下位置:匹配代码链接起来，但是数据编号没有链接.例如:
I have two sheets, one of which contains data for all of the match codes (Master Sheet) and another that contains data for only some match some codes. These codes link to a data number (as well as other values) that I need to bring in from the "Master Sheet" to the other sheet. I used index match initially to bring over the values and data number, however I unfortunately did not notice that there are duplicate match codes that correspond to different values and data numbers, so I want to be able to go in and copy paste any data where the match codes link up, but the data number does not. For example:
Master Sheet
Match Code Value 1 Value 2 Rate data number
11111 1500 1200 2700 656565
11111 1800 1800 3600 688888
11112 1500 1100 2600 818987
11112 1500 150 1650 986773
12343 200 800 1000 785942
Sheet 2
Match Code Value 1 Value 2 Rate data number
11111 1500 1200 2700 656565
11112 1500 150 1650 986773
可以看出，工作表2和主工作表一样具有匹配代码11111和11112，但是我需要带入所有具有相应匹配值但数据编号不同的数据.但是，我无法复制整个母版表，因为该母版表包含在工作表2中找不到的匹配值，例如12343.因此，完成后，工作表2看起来像这样:
As can be seen, Sheet 2 has Match codes 11111 and 11112 as does the Master Sheet, however I need to bring over all of the data that has corresponding match values but different data numbers. I however cannot copy over the entire master sheet because the Master sheet contains Match values not found in Sheet 2 such as 12343. Thus, sheet 2 would look like this after completed:
Sheet 2
Match Code Value 1 Value 2 Rate data number
11111 1500 1200 2700 656565
11111 1800 1800 3600 688888
11112 1500 1100 2600 818987
11112 1500 150 1650 986773
是否有一种方法可以使宏检查工作表2中的匹配值，对于工作表之间的每个对应匹配值，如果工作表2中还没有该确切的行，则复制整个行并将其粘贴进入工作表2?
Is there a way to make a macro to check the Match values in Sheet 2, and for every corresponding match value between the sheets, if that exact row is not already in Sheet 2, then copy over the entire row and paste it into sheet 2?
我有以下内容，但它没有按照我想要的去做:
I have the following, but it isn't doing what I want it to:
Sub pasteLoop()
'Iterator Worksheet 1, is the counter for the ws1 column
Dim iWS1 As Integer
'Iterator Worksheet 2, is the counter for the ws2 column
Dim iWS2 As Integer
'Switch New Row, is the switch if the next value need a new row
Dim sNR As Integer
'Maximal Row Count, need to be extend when new rows are added
Dim MaxRows As Integer
'valueHolder, is the holder for the orginal value, the orginal value might be replaced on the sheet
Dim valueHolder As Long
'Worksheet1
Dim ws1 As Worksheet
'Worlsheet2
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet 2")
Set ws2 = ActiveWorkbook.Worksheets("Master Sheet")
'Set iWS1 to the first row
iWS1 = 1
'Get MaxRows
MaxRows = ws1.Cells(Rows.Count, 1).End(xlUp).Row
'Loop through the Rows on WS1 setting switch to 0 and store the value from the ws1 row in the holder
While iWS1 <= MaxRows
sNR = 0
valueHolder = ws1.Cells(iWS1, 1).Value
'Loop through the Rows on WS2, searching for a value that match with the value from ws1
For iWS2 = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
'When it matches, then look if there was already a match with the value, if not replace it on the ws1 and increase the sNr to 1
If valueHolder = ws2.Cells(iWS2, 1).Value Then
If (sNR < 1) Then
ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2).Value
sNR = sNR + 1
'When the sNR is already > 0, increase the Iterator for the ws1 that he will point on the new line
'increase the maxrows because we got one more soon, finally insert the new row and store the value from ws2 in it
Else
iWS1 = iWS1 + 1
MaxRows = MaxRows + 1
Range(ws1.Cells(iWS1, 1), ws1.Cells(iWS1, 1)).EntireRow.Insert
ws1.Cells(iWS1, 1).Value = ws2.Cells(iWS2, 2)
End If
End If
Next iWS2
iWS1 = iWS1 + 1
Wend
End Sub
推荐答案
- 构建一个匹配代码字典并对其进行过滤.
- 将所有过滤后的内容复制到第二个工作表中.
- 根据匹配代码和数据号删除重复项.
- [可选]对新数据进行排序.
顺便说一句，您的原始代码显示的是 Sheet 2 ，而不是 Sheet2 .
BTW, your original code shows Sheet 2, not Sheet2.
Option Explicit
Sub same_old_same_old()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim d As Long, dMNUMs As Object
Set ws1 = ActiveWorkbook.Worksheets("Master Sheet")
Set ws2 = ActiveWorkbook.Worksheets("Sheet 2")
Set dMNUMs = CreateObject("Scripting.Dictionary")
dMNUMs.CompareMode = vbBinaryCompare
'1. Build a dictionary of match codes and filter on those.
With ws2
For d = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
dMNUMs.Item(CStr(.Cells(d, "A").Value2)) = .Cells(d, "E").Value2
Next d
End With
'2. Copy everything filtered over to the second worksheet.
With ws1
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.AutoFilter Field:=1, Criteria1:=dMNUMs.keys, Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.Copy _
Destination:=ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
'3. Remove duplicates based on match code and data number.
'4. [optional] Sort the new data
With ws2
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.RemoveDuplicates Columns:=Array(1, 5), Header:=xlYes
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Key2:=.Columns(5), Order2:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
End With
End With
dMNUMs.RemoveAll: Set dMNUMs = Nothing
End Sub
这篇关于Excel宏可根据特定的匹配条件将数据从一张纸复制到另一张纸的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
