Excel VBA：滿足條件時將列復制到另一個工作表

Question

我有一個數據集，其名稱在 A 列中，每個名稱在 B 列中有一個是或否。 我想做以下事情：

如果 Column A Sheet 1 中的值在 Column B Sheet 1中有Yes ，則僅將這些值復制到Sheet 2 中的 A 列

這是我到目前為止所擁有的：

Private Sub CommandButton1_Click()
Dim name As Long
Worksheets("Sheet2").Select

name = ActiveSheet.Cells(1, 1).CurrentRegion.Rows.Count + 1
       Worksheets("Sheet1").Select
       Worksheets("Sheet1").Range("A2").Select
       
       Range(Selection, Selection.End(xlDown)).Select
       Selection.Copy Sheets("Sheet2").Cells(name, 1)
End Sub

如何讓此代碼僅將 A 列中 B 列中為“是”的值復制到 Sheet2？

Answer 1

使用標准復制

• 調整const ants 部分中的值以滿足您的需要。

“循環通過每個單元格”版本

Option Explicit

Sub copyCriteria()
    
    ' Source
    Const srcName As String = "Sheet1"
    Const ValueColumn As Variant = "A"      ' e.g. 1 or "A"
    Const CriteriaColumn As Variant = "B"   ' e.g. 1 or "A"
    Const srcFirstRow As Long = 2
    
    ' Target
    Const tgtName As String = "Sheet2"
    Const tgtColumn As Variant = "A"        ' e.g. 1 or "A"
    Const tgtFirstRow As Long = 2
    
    ' Other
    Const Criteria As String = "Yes"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Calculate Source Last Row.
    Dim src As Worksheet: Set src = wb.Worksheets(srcName)
    Dim rng As Range: Set rng = src.Cells(src.Rows.Count, ValueColumn).End(xlUp)
    Dim srcLastRow As Long: srcLastRow = rng.Row
    If srcLastRow < srcFirstRow Then Exit Sub
                                    
    ' Looping through cells in Criteria Column, check if the value
    ' in each cell is equal to Criteria. If it is then write the 'corresponding'
    ' value from Value Column to Target Column.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
    Dim tgtRow As Long: tgtRow = tgtFirstRow - 1
    Dim i As Long
    For i = srcFirstRow To srcLastRow
        If src.Cells(i, CriteriaColumn).Value = Criteria Then
            tgtRow = tgtRow + 1
            tgt.Cells(tgtRow, tgtColumn).Value = src.Cells(i, ValueColumn).Value
        End If
    Next i
 
    ' Inform user.
    MsgBox "Copied '" & tgtRow - tgtFirstRow + 1 & "' values.", vbInformation

End Sub