VBA Compare 2 sheets, move old comments to new sheet

Question

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)

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.

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

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.

tigeravatar · Accepted Answer

Give this a try:

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 Compare 2 sheets, move old comments to new sheet

Answers (2)

Related Questions