vba excel比较两个不同工作表中的列，然后以重复的行数将行从一个列复制到另一列

vba excel compare columns in two different sheets then copy row from one to the other column at the duplicate row count

提问by cheapkid1

Two columns, separate sheets, each have part number in them. Column1 is updated and Column2 is copied from Column1 before Column1 is updated to retain associated row values and information per part number. Now if Column1 is updated and the row counts between Column1 and Column2 don't match anymore, I cannot find anything on comparing columns with different row counts where duplicates occur. How can I compare the columns and if there is a duplicate, take the duplicate row from Column2 and copy it to Column1 where the duplicate occurred(same part number)? Like if before Column1 was updated there was a part number 2222 in cell A1, so that data would be copied over to Column2 to A1. After the update of Column1 the part number 2222 might be in A8 now. Now the row counts don't match between columns, so I cannot do row count, and I cannot just copy a range over from one sheet to the other. Any help would be much appreciated.

两列，单独的工作表，每列都有零件号。在更新 Column1 之前更新 Column1 并从 Column1 复制 Column2 以保留关联的行值和每个部件号的信息。现在，如果 Column1 已更新并且 Column1 和 Column2 之间的行数不再匹配，则在比较发生重复的不同行数的列时，我找不到任何内容。我如何比较列，如果有重复，从 Column2 中取出重复的行并将其复制到 Column1 发生重复的地方（相同的部件号）？就像在更新 Column1 之前，单元格 A1 中有一个部件号 2222，因此数据将被复制到 Column2 到 A1。在 Column1 更新后，部件号 2222 现在可能在 A8 中。现在行数在列之间不匹配，所以我不能做行数，而且我不能只是将范围从一张纸复制到另一张纸。任何帮助将非常感激。

Sub DeleteRowsandCopyRowstoduplicate()

'Deletes rows where one cell does not meet criteria

Dim ws1 As Worksheet: Set ws1 = ActiveWorkbook.Sheets("machine schedule")
Dim ws2 As Worksheet: Set ws2 = ActiveWorkbook.Sheets("Sync Data")
Dim criteria As String
Dim found As Range
Dim i As Long

Application.ScreenUpdating = False

For i = 60 To 3 Step -1
   criteria = ws2.Cells(i, 1).Value
   On Error Resume Next
   Set found = ws1.Range("A:A").Find(What:=criteria, LookAt:=xlWhole)
   On Error GoTo 0
If found Is Not Nothing Then
    ws2.Cells(i, 1).EntireRow.Copy Destination:= '**not sure what to put here because it's always changing

If found Is Nothing Then
     ws2.Cells(i, 1).EntireRow.ClearContents ' or .Delete
   End If

  Next i

Application.ScreenUpdating = True

End Sub

回答by ron

Your new info changes my understanding of the problem, so I've modified the macro accordingly. I've tested this and it gives the same output as what you posted in your links. Hopefully it does what you want.

您的新信息改变了我对问题的理解，因此我相应地修改了宏。我已经对此进行了测试，它提供了与您在链接中发布的内容相同的输出。希望它可以满足您的需求。

Sub DeleteRowsandCopyRowstoduplicate()

' Deletes rows where one cell does not meet criteria

Dim ws1 As Worksheet: Set ws1 = ActiveWorkbook.Sheets("machine schedule")
Dim ws2 As Worksheet: Set ws2 = ActiveWorkbook.Sheets("Sync Data")
Dim criteria As String
Dim found As Range
Dim i As Long

    Application.ScreenUpdating = False

' Determine the number of row of updated data on ws 2
    ws2.Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    numb = Selection.Rows.Count

' Iterate through the data, when data from col A of ws2 is found to match data
' in col A of ws1, add data from all other columns to ws1
    For i = numb To 1 Step -1
        ws2.Select
        Cells(i, 1).Select
        ActiveCell.EntireRow.Copy
        criteria = ActiveCell

        my_marker = 1
        ws1.Select
        Range("A1").Select  ' or wherever it's appropriate to start
        Do Until IsEmpty(ActiveCell) = True
           If ActiveCell = criteria Then
                ActiveSheet.Paste
                my_marker = 2
                Exit Do
           Else
           End If
           ActiveCell.Offset(1, 0).Select
        Loop

        ws2.Select
        If my_marker = 1 Then
            ws2.Cells(i, 1).EntireRow.Delete
        Else
        End If
    Next i

' Remove any rows from ws1 that were not on ws2
    ws1.Select
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    numb2 = Selection.Rows.Count
    Range("B1").Select

    For i = 1 To numb2
        If IsEmpty(ActiveCell) = True Then
            ActiveCell.EntireRow.Delete
        Else
            ActiveCell.Offset(1, 0).Select
        End If
    Next
    Range("A1").Select

' sort ws2 by col A
    ws2.Select
    Cells.Select
    Application.CutCopyMode = False
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

    Range("A1").Select
    Application.ScreenUpdating = True
End Sub