匹配三个条件并复制粘贴数据

Question

如果找到下面的代码匹配特定范围内的字符串（此范围包含标题），则复制整个列并粘贴到 Sheet2。

我想在下面的代码中再添加两个条件：

Dim FindValue2 As String
Dim FindValue3 As String
FindValue2 = shSummary.Range("A2").Value
FindValue3 = shSummary.Range("B2").Value

在匹配这 3 个条件后，在 Sheet1 Column A 中匹配 FindValue3 和 Column F 对于 FindValue2，然后复制并粘贴数据。

您的帮助将不胜感激。

Sub find()

Dim foundRng As Range
Dim FindValue As String
Dim lastRow As Long

Set shData = Worksheets("Sheet1")
Set shSummary = Worksheets("Sheet2")

FindValue = shSummary.Range("C2")

Set foundRng = shData.Range("G1:Z1").find(FindValue)
With shData
lastRow = .Cells(.Rows.Count, foundRng.Column).End(xlUp).Row
End With
    
shData.Rows("2:" & lastRow).Columns(foundRng.Column).Copy shSummary.Range("I3")
    
End Sub

Answer 1

对列 A 和 F 应用过滤器，然后复制可见单元格。

Option Explicit
Sub Find3()

    Dim wb As Workbook, wsData As Worksheet, wsSummary As Worksheet
    Dim rngFound As Range, rngData As Range, rngCopy As Range
    Dim FindValue As String, FilterA As String, FilterF As String
    Dim lastRow As Long, c As Long
    
    Set wb = ThisWorkbook
    Set wsData = wb.Worksheets("Sheet1")
    wsData.AutoFilterMode = False

    Set wsSummary = wb.Worksheets("Sheet2")
    With wsSummary
        FindValue = .Range("B2")
        FilterA = .Range("C2")
        FilterF = .Range("A2")
    End With

    Set rngFound = wsData.Range("G1:Z1").find(FindValue)
    If rngFound Is Nothing Then
        MsgBox "'" & FindValue & "' not found", vbCritical
        Exit Sub
    End If

    ' column matching FindValue
    c = rngFound.Column
    lastRow = wsData.Cells(Rows.Count, c).End(xlUp).Row
    If lastRow = 1 Then
        MsgBox "No data in column " & c, vbCritical
        Exit Sub
    End If
    
    ' filter data on colA and F
    With wsData
         Set rngData = .Cells(2, c).Resize(lastRow - 1)
         .UsedRange.AutoFilter
         .UsedRange.AutoFilter Field:=1, Criteria1:=FilterA
         .UsedRange.AutoFilter Field:=6, Criteria1:=FilterF

         ' data to copy
         On Error Resume Next
         Set rngCopy = rngData.SpecialCells(xlCellTypeVisible)
         On Error GoTo 0

         ' copy data
         If rngCopy Is Nothing Then
             MsgBox "No data to copy from column " & c, vbCritical
             .AutoFilterMode = False
             Exit Sub
         Else
             rngCopy.Copy wsSummary.Range("I3")
         End If
         .AutoFilterMode = False
    End With

    MsgBox "Done"
End Sub

Answer 2

将数据列复制到另一个工作表

• 调整常量部分中的值。
• 完成测试后删除（注释掉）Debug.Print 行。

Option Explicit

Sub ExportDataColumns()
    
    Const sName As String = "Sheet1"
    Const sHeadersAddress As String = "G1:Z1"
    
    Const dName As String = "Sheet2"
    Const dReadList As String = "A2,B2,C2"
    Const dWriteList As String = "F3,A3,I3"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim wsrCount As Long: wsrCount = sws.Rows.Count

    Dim shrg As Range: Set shrg = sws.Range(sHeadersAddress)
    Debug.Print "Source Header Range:     " & shrg.Address(0, 0)
    
    Dim sfRow As Long: sfRow = shrg.Row + 1 ' first row below the headers
    Debug.Print "Source First Row:        " & sfRow
    If sfRow >= wsrCount Then Exit Sub

    Dim slRow As Long: slRow = GetLastRow(shrg)
    Debug.Print "Source Last Row:         " & slRow
    If slRow < sfRow Then Exit Sub
    
    Dim sdrg As Range
    Set sdrg = shrg.Resize(slRow - sfRow + 1).Offset(1)
    Debug.Print "Source Data Range:       " & sdrg.Address(0, 0)
    
    Dim dRead() As String: dRead = Split(dReadList, ",")
    Dim dWrite() As String: dWrite = Split(dWriteList, ",")
    Dim dUpper As Long: dUpper = UBound(dRead)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
   
    Dim srg As Range
    Dim drg As Range
    Dim dcrg As Range
    Dim srCount As Long
    Dim n As Long
    For n = 0 To dUpper
        Debug.Print "Item " & n + 1
        Dim scIndex As Variant
        scIndex = Application.Match(dws.Range(dRead(n)).Value, shrg, 0)
        If IsNumeric(scIndex) Then
            Set srg = sdrg.Columns(scIndex)
            Debug.Print "Source Range:            " & srg.Address(0, 0)
            srCount = srg.Rows.Count
            Set drg = dws.Range(dWrite(n)).Resize(srCount)
            Debug.Print "Destination Range:       " & drg.Address(0, 0)
            drg.Value = srg.Value
            Set dcrg = drg.Resize(wsrCount - drg.Row - srCount + 1) _
                .Offset(srCount)
            Debug.Print "Destination Clear Range: " & dcrg.Address(0, 0)
            dcrg.ClearContents
        End If
    Next n
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the worksheet row number of the last non-empty row
'               in the range from the first row of a range ('rg')
'               through the same sized bottom-most row of the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetLastRow( _
    ByVal rg As Range) _
As Long
    If rg Is Nothing Then Exit Function
    
    Dim lCell As Range
    With rg.Rows(1)
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
    End With
    If lCell Is Nothing Then Exit Function
    
    GetLastRow = lCell.Row
End Function