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

Question

我有一个包含 1 年数据的电子表格，我需要将其分成季度工作表。

我需要复制的数据位于 A:B 和 L:N 列中，但前提是 L:N 列中有“Y”。

主要数据在“客户列表”表上，目标表是“Wool 1st Qtr”。 我有 2 个 header 行，使数据从第 3 行开始。

我一直在查看公式和 VBA，但我很难在 Google 上找到一个可以修改的类似答案，并且在查看了 100 个不同的问题之后，它们都开始看起来一样了！

我已经使用命令按钮尝试了此代码，但它正在复制整行。 它也只从一列中取“Y”。

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

导出到另一个工作表

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