根据多个单元格中的条件将一行中的单元格（不是整行）复制到另一个工作表

Question

I have a spreadsheet with data for 1 year that I'm needing to separate onto quarterly sheets.

The data I need copied is in columns A:B & L:N, but only if there is a "Y" in columns L:N.

The main data is on sheet "Client List", & the destination sheet is "Wool 1st Qtr". I have 2 header rows, making the data starting on row 3.

I've been looking at both Formulas & VBAs but I'm struggling to find a similar answer on Google that I can modify, & after looking at what feels like 100 different questions they're all starting to look the same!

I've tried this code using a command button, but it is copying the entire row. It is also only taking the "Y" from one column.

Private Sub CommandButton1_Click()  
a = Worksheets("Client List").Cells(Rows.Count, 1).End(xlUp).Row

For i = 3 To a

    If Worksheets("Client List").Cells(i, 12).Value = "Y" Then
    
        Worksheets("Client List").Rows(i).Copy
        Worksheets("Wool 1st Qtr").Activate
        b = Worksheets("Wool 1st Qtr").Cells(Rows.Count, 1).End(xlUp).Row
        Worksheets("Wool 1st Qtr").Cells(b + 1, 1).Select
        ActiveSheet.Paste
        Worksheets("Client List").Activate
        
    End If
Next

Application.CutCopyMode = False

ThisWorkbook.Worksheets("Client List").Cells(3, 1).Select

End Sub

Answer 1

Export to Another Worksheet

Option Explicit

Private Sub CommandButton1_Click()
    ExportQuarter
End Sub

Sub ExportQuarter()
    
    Const sName As String = "Client List"
    Const sCols1 As String = "A:B"
    Const sCols2 As String = "L:N"
    Const slrCol As String = "A"
    Const sfRow As Long = 3
    Const sCriteriaString As String = "Y"
    
    Const dName As String = "Wool 1st Qtr"
    Const dCol As String = "A"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim srg As Range: Set srg = sws.Rows(sfRow).Columns(sCols2).Resize(srCount)
    Dim scCount As Long: scCount = srg.Columns.Count
    
    Dim ddrg As Range
    Dim srrg As Range
    For Each srrg In srg.Rows
        If Application.CountIf(srrg, sCriteriaString) = scCount Then
            If ddrg Is Nothing Then
                Set ddrg = srrg.Cells(1)
            Else
                Set ddrg = Union(ddrg, srrg.Cells(1))
            End If
        End If
    Next srrg
    
    If ddrg Is Nothing Then Exit Sub ' no match
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range
    Set dfCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp).Offset(1)
    
    Intersect(ddrg.EntireRow, Union(srg, sws.Columns(sCols1))).Copy dfCell
    
    MsgBox "Quarter exported.", vbInformation, "ExportQuarter"
    
End Sub