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

示例：

表1，A栏（开始第2行）

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

表2，A栏（开始第2行）

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

结果：

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

为你的＃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

它应该按预期工作

测试数据和结果：

TestResult

Answer 2

为什么不将整个行从sheet2复制到sheet1，如

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

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

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

2 个答案: