返回找到匹配的列的第 1 行

Question

在我的工作簿上，一个命令按钮循环遍历 A、D、G 和 J 列中的每个单元格。
如果单元格包含蓝色边框，则它正在另一个工作簿上搜索其匹配项。
如果找到该匹配项，则将原始工作簿中的单元格值放置到第二个工作簿中，在找到匹配项的下一列中。

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

我正在尝试将原始工作簿中的第一行（A1、D1、G1 或 J1）返回到第二个工作簿上新放置的值的相邻列中。

例子：

• 在工作簿 1 上，名称“John Doe”和“Jane Doe”在 A 列中有蓝色边框。
• 在工作簿 2 中，“John Doe”位于 A 列第 123 行，“Jane Doe”位于 A 列第 250 行。
• 宏将“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, 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, testRange, 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 

Answer 1

已编译但未测试：

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, 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