在一个单元格内查找具有不同字符串的匹配单元格

Question

我的宏目标：

我有 2 张表，sheet1 主报告和 sheet2 导入输入。

在两张纸的 A 列中，我在一个单元格中有多个字符串。我想看看是否有匹配项，如果有匹配项，sheet2 中的行（来自 B 列）将被复制并粘贴到 sheet1 中对应的行中。

我的这部分代码已经完成。
但现在它开始变得棘手了：如果在与匹配字符串相同的单元格中有新字符串，那么我想将它们也添加到列 A sheet1.

例如：

Sheet1 Column A Cell34:
MDM-9086

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

宏之后是这样的：

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

如果两张纸的 A 列不匹配，那么我想复制 sheet2 的整行并将其粘贴到 sheet1.

查看我的代码：

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

示例：

Sheet 1，A 列（第 2 行开始）

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

Sheet 2，A列（第2行开始）

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

结果 Sheet 1，A 列（第 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

为什么不将整行从 sheet2 复制到 sheet1 就像

For NxtRw = 2 To LastRw2
    ...
    Sheets(2).Range("A" & NxtRw & ":Q" & NxtRw).Copy _
    Sheets(1).Range("A" & m.Row)
    ...
Next NxtRw

？（循环的其余部分应该保持不变。）

Answer 2

为了你的#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

现在应该可以正常工作了

测试数据及结果：

在一个单元格内查找具有不同字符串的匹配单元格

Find matching cell with different strings inside one cell

vba

excel

loops

string-matching