excel - VBA比较2张，将旧评论移至新表

Question

基本上我有这个脚本比较两张表，它将列中的值与新表进行比较，如果找到该值，它会将信息从旧表“B”复制到新表“B”列。

该脚本完美无缺（感谢作者）

我试图将其配置为不仅搜索和比较 1 列，而且还比较 2，如果 X AND Y 列等于新工作表中的 X AND Y，它将执行相同的任务。

这样做的原因是有时我在几个不同的行中有它搜索的值，所以当它比较时它会在几个地方找到它。虽然此脚本仅在存在唯一的“查找”值时才能完美运行。

你能帮我编辑使它适合“查找”并比较列“P”和列“V”如果它们在新表中相同，它将复制列“B”旧表中的值到“B”新表.

Sub movecommentsInternode()
Dim Wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rSourcePCol As Range
Dim rSourcePCell As Range
Dim rDestPCol As Range
Dim rFound As Range
Dim sFirst As String
Dim sNotFound As String

Set Wb = ActiveWorkbook
Set wsSource = Wb.Sheets("Internode Buffer")
Set wsDest = Wb.Sheets("DataInternode")
Set rSourcePCol = wsSource.Range("P2", wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp))
Set rDestPCol = wsDest.Range("P2", wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp))


If rSourcePCol.row < 2 Then
    MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
    Exit Sub
ElseIf rDestPCol.row < 2 Then
    MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
    Exit Sub
End If

For Each rSourcePCell In rSourcePCol.Cells
    Set rFound = rDestPCol.Find(rSourcePCell.Value, rDestPCol.Cells(rDestPCol.Cells.Count), xlValues, xlWhole)
    If rFound Is Nothing Then
        sNotFound = sNotFound & Chr(10) & rSourcePCell.Value
    Else
        sFirst = rFound.Address
        Do
            rFound.Offset(, -14).Value = rSourcePCell.Offset(, -14).Value
            Set rFound = rDestPCol.FindNext(rFound)
        Loop While rFound.Address <> sFirst
    End If
Next rSourcePCell

If Len(sNotFound) = 0 Then
    MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
Else
    MsgBox ("Import completed" & vbCrLf & "The following tag-comments have not been merged with new IO-List:" & sNotFound)
End If
End Sub

还有一件额外的事情：你能帮我让它在一个列表（新工作表）中显示缺失的标签作为评论。如果在 Msgbox 中显示了数百个缺失的标签，将被确认。

标签： excelvba

Answer 1

试试这个：

Sub movecommentsInternode()

    Dim Wb As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim wsMissingTags As Worksheet
    Dim rSourcePCol As Range
    Dim rSourcePCell As Range
    Dim rDestPCol As Range
    Dim rFound As Range
    Dim sFirst As String
    Dim sNotFound As String
    Dim bFound As Boolean
    Dim aHeaders() As Variant
    Dim aMissingTags As Variant

    Set Wb = ActiveWorkbook
    Set wsSource = Wb.Sheets("Internode Buffer")
    Set wsDest = Wb.Sheets("DataInternode")
    Set rSourcePCol = wsSource.Range("P2", wsSource.Cells(wsSource.Rows.Count, "P").End(xlUp))
    Set rDestPCol = wsDest.Range("P2", wsDest.Cells(wsDest.Rows.Count, "P").End(xlUp))

    If rSourcePCol.Row < 2 Then
        MsgBox "No comment available, therefor no import is needed " ' & wsSource.Name
        Exit Sub
    ElseIf rDestPCol.Row < 2 Then
        MsgBox "Data Sheet is empty, please import the correct IO-List to be able to merge the comments " ' & wsDest.Name
        Exit Sub
    End If

    For Each rSourcePCell In rSourcePCol.Cells
        bFound = False
        Set rFound = rDestPCol.Find(rSourcePCell.Value, rDestPCol.Cells(rDestPCol.Cells.Count), xlValues, xlWhole)
        If Not rFound Is Nothing Then
            sFirst = rFound.Address
            Do
                If rSourcePCell.Offset(, 6).Value = rFound.Offset(, 6).Value Then
                    rFound.Offset(, -14).Value = rSourcePCell.Offset(, -14).Value
                    bFound = True
                End If
                If bFound = True Then Exit Do   'First match for both columns found, exit find loop (this line can be removed if preferred)
                Set rFound = rDestPCol.FindNext(rFound)
            Loop While rFound.Address <> sFirst
        End If
        If bFound = False Then sNotFound = sNotFound & "|" & rSourcePCell.Value & vbTab & rSourcePCell.Offset(, 6).Value
    Next rSourcePCell

    If Len(sNotFound) = 0 Then
        MsgBox ("Import completed" & vbCrLf & "All comments have been merged with the new imported IO-List")
    Else
        On Error Resume Next
        Set wsMissingTags = Wb.Worksheets("Missing Tags")
        On Error GoTo 0
        If wsMissingTags Is Nothing Then
            'Missing Tags worksheet doesn't exist, create it and add headers
            aHeaders = Array(wsSource.Range("P1").Value, wsSource.Range("V1").Value)
            Set wsMissingTags = Wb.Worksheets.Add(After:=Wb.Worksheets(Wb.Worksheets.Count))
            wsMissingTags.Name = "Missing Tags"
            With wsMissingTags.Range("A1").Resize(, UBound(aHeaders) - LBound(aHeaders) + 1)
                .Value = aHeaders
                .Font.Bold = True
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
            End With
        Else
            'Missing Tags worksheet already exists, clear previous contents (if any)
            wsMissingTags.Range("A1").CurrentRegion.Offset(1).ClearContents
        End If
        aMissingTags = Split(Mid(sNotFound, 2), "|")
        With wsMissingTags.Range("A2").Resize(UBound(aMissingTags) - LBound(aMissingTags) + 1)
            .Value = Application.Transpose(aMissingTags)
            .TextToColumns .Cells, xlDelimited, Tab:=True
        End With
        MsgBox "Import completed" & vbCrLf & "See the Missing Tags worksheet for a list of tag-comments that have not been merged with new IO-List."
    End If

End Sub