How to copy a value and paste it to another sheet based on a criteria

user_8666758 0
Viewed 308

I am trying to copy a value and paste it to another sheet based on criteria of a cell value by iterating a range.

Criteria: if a cell value of a row of the range has "new", copy a value of a different cell of the same row. For example, look for 'new' in NewProd column, and if found, copy the values of Product AND Desc columns(the values of the two columns) of the same row.

The table looks like this: Table1

Problem: when pasting the copied value, the first iteration gets the correct value(the yellow row value), however the second iteration gets the same value as the first one. It should be the green row value in the image, but gets the yellow row value.

My code:

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
vba excel
1 Answers

If you have Office 365 then you can use the new Filter-Function:

enter image description here

If you want to do it by VBA I suggest the following code:

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
user_165784240
Related