如何根據條件復制值並將其粘貼到另一個工作表

Question

我正在嘗試根據單元格值的條件通過迭代范圍來復制一個值並將其粘貼到另一個工作表中。

條件：如果范圍內某行的單元格值有“new”，則復制同一行不同單元格的值。 例如，在NewProd列中查找'new'，如果找到，則復制同一行的Product AND Desc列的值（兩列的值）。

該表如下所示：表 1

問題：粘貼復制的值時，第一次迭代獲得正確的值（黃色行值），但是第二次迭代獲得與第一次相同的值。 它應該是圖像中的綠色行值，但獲取黃色行值。

我的代碼：

Sub AddNewProd()

Dim tbl As ListObject
Dim lr As Long
Dim lr2 As Long
Dim c As Range
Dim rng As Range
Dim prd As Range
Dim desc As Range

Set tbl = Sheets("sheet1").ListObjects("Table1")
'Count the number of the row of the NewProd column.
lr = tbl.Range.Rows.Count
lr2 = Sheets("sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row

Sheets("sheet1").Select

Set rng = Sheets("sheet1").Range("AS2:AS" & lr)
Set prd = tbl.ListColumns("Product").DataBodyRange
Set desc = tbl.ListColumns("Desc").DataBodyRange

For Each c In rng
    If c = "New" Then
    prd.Offset(1).Resize(1, 2).SpecialCells(xlCellTypeVisible).Copy
    Sheets("sheet2").Select
    Range("A" & lr2 + 1).Select
    ActiveSheet.Paste
    lr2 = Sheets("sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
    Application.CutCopyMode = False

    End If
    Next c
 End Sub

Answer 1

如果您有 Office 365，則可以使用新的Filter -Function：

如果你想通過 VBA 來做，我建議使用以下代碼：

Option Explicit

Public Enum en_TableColumns
    col_Product = 1
    col_Desc = 2
    col_isNew = 3
End Enum

Private Const ProductStatusToCopy As String = "new"

Sub copyNewProducts()

Dim loSource As ListObject
Set loSource = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")

'get source data into array
Dim arrSourceData As Variant
arrSourceData = loSource.DataBodyRange.Value

Dim cntNewProducts As Long
cntNewProducts = Application.WorksheetFunction.CountIf(loSource.ListColumns(col_isNew).DataBodyRange, ProductStatusToCopy)

Dim arrTargetData As Variant
ReDim arrTargetData(1 To cntNewProducts, 1 To 2)

Dim rSourceRow As Long, rTargetRow As Long
For rSourceRow = 1 To UBound(arrSourceData, 1)
    If arrSourceData(rSourceRow, col_isNew) = ProductStatusToCopy Then
        'copy product data to target array if new
        rTargetRow = rTargetRow + 1
        arrTargetData(rTargetRow, col_Product) = arrSourceData(rSourceRow, col_Product)
        arrTargetData(rTargetRow, col_Desc) = arrSourceData(rSourceRow, col_Desc)
    End If
Next
   
'write target array to sheet2 - writing an array to a sheet is much, much faster than writing cell per cell
With ThisWorkbook.Worksheets("Sheet2").Cells(2, 1)
    .CurrentRegion.Clear
    .Resize(cntNewProducts, 2).Value = arrTargetData
End With

End Sub