还返回找到匹配项的列的第1行吗？

如何解决还返回找到匹配项的列的第1行吗？

我的文件快要完成了，我很奇怪地停留在最后一部分。我认为我的大脑再也无法通过Excel进行思考了，所以我希望你们可以在这看似简单的最后一部分中为我提供帮助。

简而言之：在我当前的工作簿上，此命令按钮在A，D，G和J列中带有蓝色边框的每个单元格中循环。如果单元格包含蓝色边框，则它将在另一个工作簿上找到其完全匹配的内容。如果找到该匹配项，它将把原始工作簿中的单元格值放到找到该匹配项的下一列中的第二个工作簿中。

我有2条if语句，用于检查下一列是否为空，然后将其放在该值中；如果不是，则在该行中找到下一个空单元格，并将其放在那里。

我想做的就是将原始工作簿的第一行（A1，D1，G1或J1）返回到第二个工作簿上新放置值的相邻列中。

示例：

在工作簿1上，名称“ John Doe”和“ Jane Doe”在列A中被发现带有蓝色边框。在工作簿2上，在A列的第123行中找到了“ John Doe”，在A列的第250行中找到了“ Jane Doe”。

宏将“ John Doe”放置在B列的第123行中，并将“ Jane Doe”放置在B列的第250行中（假设B123和B250中的单元格为空）。

在工作簿1中，我还希望将单元格值放在A1中-放入工作簿2：C列，第123行和250行。

但是我想同时对A D G J列执行此操作（下面的代码中的rr3dest是我试图将此值设置为的值，我知道现在没有将其设置为任何值）。

我的大脑被炸了！我觉得我应该知道这一点。

我们非常感谢您的帮助。抱歉，如果解释太多，我会尽量保持清晰。

Private Sub CommandButton3_Click()

Dim testWS As Worksheet
Dim testRange As Range,idCella As Range
Dim alastRow2 As Long,resultM As Integer
Dim rr2dest As Range,rr3dest As Range

Set testWS = Workbooks("Test.xlsx").Worksheets("October")                                       'set the 2nd workbook as testWS
Set testRange = testWS.Columns(1)                                                                                            'searching only column A on testWS (2nd workbook)
alastRow2 = Worksheets("Reruns To Pull").Cells(Rows.Count,"A").End(xlUp).Row                   'find last row in column A that has data on current workbook
dlastRow2 = Worksheets("Reruns To Pull").Cells(Rows.Count,"D").End(xlUp).Row
glastrow2 = Worksheets("Reruns To Pull").Cells(Rows.Count,"G").End(xlUp).Row
jlastrow2 = Worksheets("Reruns To Pull").Cells(Rows.Count,"J").End(xlUp).Row


For Each idCella In Worksheets("Reruns To Pull").Range("A1:A" & alastRow2 & ",D1:D" & dlastRow2 & ",G1:G" & glastrow2 & ",J1:J" & jlastrow2).Cells                'for each cell in Column A on current workbook (eventually I want to loop through Column A,D,G,J.  All will be variable ranges)

        If idCella.Borders.Color = RGB(0,192) Then                                                 'On current workbook,if cells in Col A borders.color = blue then

            If Not IsError(Application.Match(idCella.Value,testRange,0)) Then                                      'find exact match on Test.xlsx (2nd workbook) and store in variable resultM
                resultM = (Application.Match(idCella.Value,0))
                                                                                       
            If IsEmpty(testWS.Range("A" & CStr(resultM)).Offset(0,1)) Then                         ' if resultM.offset(0,1) is empty then set destination to .offset(0,1)
                Set rr2dest = testWS.Range("A" & CStr(resultM)).Offset(0,1)
                    rr2dest.Value = idCella.Value
                    rr2dest.Interior.Color = idCella.Interior.Color
                    rr2dest.Borders.Color = idCella.Borders.Color
                    rr2dest.Borders.Weight = idCella.Borders.Weight
                Set rr3dest = testWS.Range("A" & CStr(resultM)).Offset(0,2)
                    
            ElseIf Not IsEmpty(testWS.Range("A" & CStr(resultM)).Offset(0,1)) Then                 ' if resultM.offset(0,1) is not empty then set destination to .end(xltoright).offset(0,1)
                Set rr2dest = testWS.Range("A" & CStr(resultM)).End(xlToRight).Offset(0,1)
                    rr2dest.Value = idCella.Value
                    rr2dest.Interior.Color = idCella.Interior.Color
                    rr2dest.Borders.Color = idCella.Borders.Color
                    rr2dest.Borders.Weight = idCella.Borders.Weight
                End If
            End If
        End If
    
Next idCella

    testWS.Range("A2:M80").WrapText = True
    testWS.Columns("A:M").HorizontalAlignment = xlCenter
    testWS.Columns("A:M").VerticalAlignment = xlVAlignCenter
    
End Sub

解决方法

已编译但未经测试：

Private Sub CommandButton3_Click()

    Dim testWS As Worksheet,pullWS As Worksheet
    Dim testRange As Range,idCella As Range
    
    Dim arrSourceCols,col,v,m,c As Range
    
    Set testWS = Workbooks("Test.xlsx").Worksheets("October")   'set the 2nd workbook as testWS
    Set testRange = testWS.Columns(1)                           'searching only column A on testWS (2nd workbook)
    
    Set pullWS = ThisWorkbook.Worksheets("Reruns To Pull")
    
    arrSourceCols = Array("A","D","G","J") 'columns to be scanned and matched
    
    For Each col In arrSourceCols   'loop source columns
        For Each idCella In pullWS.Range(pullWS.Cells(1,col),_
                                         pullWS.Cells(Rows.Count,col).End(xlUp)).Cells
            If idCella.Borders.Color = RGB(0,192) Then
                v = idCella.Value                      'value to look for
                m = Application.Match(v,testRange,0) 'match?
                If Not IsError(m) Then
                    Set c = testWS.Cells(m,Columns.Count).End(xlToLeft).Offset(0,1) 'get empty cell
                    c.Value = v                                       'put the matched value
                    CopyFormats idCella,c                            'transfer formatting
                    c.Offset(0,1).Value = pullWS.Cells(1,col).Value 'put the header from the column
                End If  'matched
            End If      'blue borders
        Next idCella
    Next col

    testWS.Range("A2:M80").WrapText = True
    testWS.Columns("A:M").HorizontalAlignment = xlCenter
    testWS.Columns("A:M").VerticalAlignment = xlVAlignCenter
    
End Sub

Sub CopyFormats(cFrom As Range,cTo As Range)
    With cTo
        .Interior.Color = cFrom.Interior.Color
        .Borders.Color = cFrom.Borders.Color
        .Borders.Weight = cFrom.Borders.Weight
    End With
End Sub