Matching the Three Criteria and Copy Paste the Data

Viewed 65

Below code match the string in the specific range (this range contains Headers) if finds then copy the whole column and paste into Sheet2.

I want to add two more condition in below code that are:

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

and match in Sheet1 Column A for FindValue3 and Column F for FindValue2 after matching these 3 criteria then copy and paste the data.

Your help will be much appreciated.

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
2 Answers

Apply a filter to columns A and F then copy the visible cells.

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

Copy Data Columns to Another Worksheet

  • Adjust the values in the constants section.
  • Delete (out-comment) the Debug.Print lines when done testing.
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
Related