VBA比较2张纸，将旧注释移到新纸上 [英] VBA Compare 2 sheets, move old comments to new sheet

问题描述

基本上我有比较两个工作表的脚本，该脚本将一列中的值与新工作表进行比较，如果找到该值，它将把信息从旧工作表"B"复制到新工作表"B"列.

Basically i have this script which compare 2 sheets, which compares a value in a column to the new sheet, if it finds the value, it will copy the information from Old sheet "B" to new sheet "B" column.

脚本运行正常(感谢作者)

The script is working flawlessly (Thanks to the author)

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

I have trying to configure it to search and compare not only 1 column, but 2, if column X AND Y are equal to X AND Y in the new sheet it will do the same task.

这样做的原因是，有时我会在几个不同的行中搜索它的值，因此当它进行比较时，它会在几个地方找到它.虽然此脚本仅在具有唯一的查找"值时才有效.

The reason for this is that sometimes i have the value it searches for in few different rows, so when it compares it will find it at few places. While this script works perfect only when there are unique "Find" values.

您能帮我进行修改，使其适合查找"并比较"P"列吗?如果新表中的"V"列相同，则会将"B"列的旧表中的值复制到"B"新表中.

Can you help me to edit so it fits "Find" and compare Column "P" & Column "V" if those are the same in new sheet, it will copy the Values in Column "B" old sheet to "B" new sheet.

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中有数百个缺少的标签全部显示出来，则会感到敬畏.

Also as a extra thing: Can you help me make it show the missing tags in a list (New sheet) insted of as comment. Will be ackward if there is hundreds of missing tags showing all in Msgbox.

推荐答案

尝试一下:

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

这篇关于VBA比较2张纸，将旧注释移到新纸上的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！