Find matching cell with different strings inside one cell

Question

My goal of my macro:

I have 2 sheets, sheet1 master report and sheet2 import Input.

In column A of both sheets I have several strings in one cell. I would like to see if there is a match and if there is the match the row from sheet2 (from column B) will be copied and paste in the row corresponding in sheet1.

This part of my code is done.
But now it starts to be tricky: If there is new string in the same cell as the matching string so I would like to add them as well in the cell of the column A sheet1.

For instance:

Sheet1 Column A Cell34:
MDM-9086

Sheet2 Column A Cell1:
MDM-9086,MDM-12345

After the macro it would be like this:

Sheet1 Column A cell34:
MDM-9086,MDM-12345

If there is no match between column A of both sheets so I would like to copy the entire row of the sheet2 and past it in the last free row of the sheet1.

See my code:

Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim I As Integer
Dim m As Range
Dim Tb

LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row 
LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row

With Worksheets(2)
    LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
    For NxtRw = 2 To LastRw2

        Tb = Split(.Range("A" & NxtRw), ",")

            For I = 0 To UBound(Tb)

                With Sheets(1).Range("A2:A" & LastRw1)


                    Set m = .Find(Trim(Tb(I)), LookAt:=xlPart)

                    If Not m Is Nothing Then

                    Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
                    Sheets(1).Range("B" & m.Row)

                    Set m = Nothing

                End If

            End With

        Next I

    Next NxtRw

End With
End Sub

Example:

Sheet 1, Column A (start row 2)

MDM-123,MDM-27827
MDM-1791728,MDM-124
MDM-125
MDM-126,MDM-28920
MDM-127,MDM-1008
""

Sheet 2, Column A (start row 2)

MDM-123,MDM-27272
MDM-124
MDM-125,MDM-1289
MDM-126
MDM-1008
MDM-127
MDM-172891

Result on Sheet 1, Column A (start row 2):

MDM-123,MDM-27827,MDM-27272
MDM-124,MDM-1791728
MDM-125,MDM-1289
MDM-126,MDM-28920
MDM-127,MDM-1008
MDM-1008
MDM-172891

paul bica paul bica · Accepted Answer · 2015-07-05T12:43:09

For your # 2.

Option Explicit

Public Sub MDMNumbers()

    Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
    Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
    Dim additions1 As String, additions2 As String

    LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
    LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row

    notFound = True

    For NxtRw = 2 To LastRw2
        celVal = Worksheets(2).Range("A" & NxtRw).Value2

        If Len(celVal) > 0 Then
            tb = Split(celVal, ",")
            For i = 0 To UBound(tb)
                Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
                If Not m Is Nothing And notFound Then
                    Set rng1 = Worksheets(2).Range("B" & NxtRw & ":Q" & NxtRw)
                    Set rng2 = Worksheets(1).Range("B" & m.Row & ":Q" & m.Row)
                    rng1.Copy rng2

                    With Worksheets(2).Range("A" & NxtRw)
                        additions1 = Replace(.Value2, "," & tb(i), vbNullString)
                        additions1 = Replace(additions1, tb(i) & ",", vbNullString)
                        additions1 = Replace(additions1, tb(i), vbNullString)
                    End With

                    With Worksheets(1).Range("A" & m.Row)
                        additions2 = Replace(.Value2, "," & tb(i), vbNullString)
                        additions2 = Replace(additions2, tb(i) & ",", vbNullString)
                        additions2 = Replace(additions2, tb(i), vbNullString)

                        If Len(additions2) > 0 Then
                            If Len(additions1) > 0 Then
                                .Value2 = tb(i) & "," & additions2 & "," & additions1
                            Else
                                .Value2 = tb(i) & "," & additions2
                            End If
                        Else
                            .Value2 = tb(i) & "," & additions1
                        End If
                    End With
                    Set m = Nothing
                    notFound = False
                End If
            Next
            If notFound Then
                Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
                Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
                rng1.Copy rng2
                LastRw1 = LastRw1 + 1
            End If
            notFound = True
        End If
    Next
End Sub

It should work as expected now

Test data and result:

TestResult

Find matching cell with different strings inside one cell

2 Answers