Find matching cell with different strings inside one cell - vba

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

Answer 1

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:

Answer 2

Why don't you copy the whole row from sheet2 to sheet1 like
For NxtRw = 2 To LastRw2
...
Sheets(2).Range("A" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("A" & m.Row)
...
Next NxtRw
? (The rest of the loop should stay the same.)