Excel在匹配单元格时返回整行

Question

我有一个工作簿，在 2 张不同的工作表上包含 2 张表格。 我希望 L 列（Sheet1）中与 A 列（Sheet2）中的单元格匹配的所有单元格都显示在 Sheet3 的新列表中。

但我希望能够看到 Sheet2 中显示的匹配单元格的整个 ROW。

我最初做的是一个条件格式，以便看到黄色的重复，然后我添加了这个 vba 代码来提取匹配的单元格，但我需要整行！

代码：

Sub m()
Dim c As Range
For Each c In Sheets("Sheet1").Range("E2:E300")
    If c.DisplayFormat.Interior.Color = vbYellow Then
        Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = c.Value
    End If
Next c
End Sub

感谢任何帮助。谢谢

Answer 1

您需要做的就是将 EntireRow 添加到作业的任一侧

Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Value = c.EntireRow.Value

Answer 2

复制列中的整行匹配项

• 它将循环遍历Source Column 以在Lookup Column 中查找匹配项。如果找到，它将匹配Lookup Cell的整行复制到Destination Worksheet。
• 仅运行第一个过程。它会在必要时调用其余部分。
• 调整常量部分中的值。

Option Explicit

Sub copyMatches()
    
    ' Constants
    Const lName As String = "Sheet1"
    Const lFirst As String = "L2"
    Const sName As String = "Sheet2"
    Const sFirst As String = "A2"
    Const dName As String = "Sheet3"
    Const dCol As String = "A"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Lookup
    Dim lrg As Range
    Set lrg = refNonEmptyColumn(wb.Worksheets(lName).Range(lFirst))
    If lrg Is Nothing Then Exit Sub
    Dim lData As Variant: lData = getColumn(lrg)
    
    ' Source
    Dim srg As Range
    Set srg = refNonEmptyColumn(wb.Worksheets(sName).Range(sFirst))
    If srg Is Nothing Then Exit Sub
    Dim sData As Variant: sData = getColumn(srg)
    
    ' Destination
    Dim dCell As Range
    Set dCell = refFirstEmptyCell(wb.Worksheets(dName).Columns(dCol))
    If dCell Is Nothing Then Exit Sub
            
    ' Combine
    Dim crg As Range
    Dim cIndex As Variant
    Dim r As Long
    For r = 1 To UBound(sData)
        cIndex = Application.Match(sData(r, 1), lData, 0)
        If IsNumeric(cIndex) Then
            Set crg = getCombinedRange(crg, srg.Cells(r))
        End If
    Next r
    
    ' Copy
    If Not crg Is Nothing Then
        crg.EntireRow.Copy dCell
    End If

End Sub

Function refNonEmptyColumn( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "refNonEmptyColumn"
    On Error GoTo clearError
    
    If Not FirstCell Is Nothing Then
        With FirstCell.Cells(1)
            Dim lCell As Range
            Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , , xlPrevious)
            If Not lCell Is Nothing Then
                Set refNonEmptyColumn = .Resize(lCell.Row - .Row + 1)
            End If
        End With
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function getColumn( _
    rg As Range, _
    Optional ByVal ColumnNumber As Long = 1, _
    Optional ByVal doTranspose As Boolean = False) _
As Variant
    Const ProcName As String = "getColumn"
    On Error GoTo clearError
    
    If Not rg Is Nothing Then
        If ColumnNumber > 0 And ColumnNumber <= rg.Columns.Count Then
            With rg.Columns(ColumnNumber)
                Dim rCount As Long: rCount = rg.Rows.Count
                Dim Result As Variant
                If rCount > 1 Then
                    If doTranspose Then
                        Dim Data As Variant: Data = .Value
                        ReDim Result(1 To 1, 1 To rCount)
                        Dim r As Long
                        For r = 1 To rCount
                            Result(1, r) = Data(r, 1)
                        Next r
                        getColumn = Result
                    Else
                        getColumn = .Value
                    End If
                Else
                    ReDim Result(1 To 1, 1 To 1): Result(1, 1) = .Value
                    getColumn = Result
                End If
            End With
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function refFirstEmptyCell( _
    ByVal ColumnRange As Range) _
As Range
    Const ProcName As String = "refFirstEmptyCell"
    On Error GoTo clearError
    
    If Not ColumnRange Is Nothing Then
        With ColumnRange.Columns(1)
            Dim lCell As Range
            Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
            If lCell Is Nothing Then
                Set refFirstEmptyCell = .Cells(1)
            Else
                Set refFirstEmptyCell = lCell.Offset(1)
            End If
       End With
    End If
    
ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function getCombinedRange( _
        ByVal BuiltRange As Range, _
        ByVal AddRange As Range)
    Const ProcName As String = "getCombinedRange"
    On Error GoTo clearError
    
    If AddRange Is Nothing Then
        If Not BuiltRange Is Nothing Then
            Set getCombinedRange = BuiltRange
        End If
    Else
        If BuiltRange Is Nothing Then
            Set getCombinedRange = AddRange
        Else
            If AddRange.Worksheet Is BuiltRange.Worksheet Then
                Set getCombinedRange = Union(BuiltRange, AddRange)
            End If
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function