excel - 如何根据条件复制值并将其粘贴到另一个工作表

Question

我正在尝试根据单元格值的标准通过迭代一个范围来复制一个值并将其粘贴到另一个工作表中。
标准 :如果范围内一行的单元格值有"new"，则复制同一行的不同单元格的值。
例如，在 NewProd 中查找"new"列，如果找到，复制 Product 的值和 Desc同一行的列(两列的值)。
该表如下所示:
Table1
问题 :粘贴复制的值时，第一次迭代获得正确的值(黄色行值)，但是第二次迭代获得与第一次相同的值。它应该是图像中的绿色行值，但获取的是黄色行值。
我的代码 :

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 -功能:

如果您想通过 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