Macro to add items with value to another tab

[ricdamiani]

Hi there,

Can you please help me building a macro that adds items with value in a list to a different tab?

See attached Example spreadsheet demonstrating in more details.

Thanks!

[WideBoyDixon]

I went with this macro assigned to the button:

Option Explicit
Public Sub AddItemsToList()

Dim vC As Range
Dim nR As Long

nR = Worksheets("LIST").Cells(Worksheets("LIST").Rows.Count, "A").End(xlUp).Row + 1
For Each vC In Range("E:E").SpecialCells(xlCellTypeConstants)
    With Worksheets("LIST").Cells(nR, "A")
        .Value = vC.Offset(0, -4).Value
        .Offset(0, 1).Value = vC.Value
    End With
    vC.Value = ""
    nR = nR + 1
Next vC

End Sub

Also attached.

WBD

[ricdamiani]

Thanks WBD, but I'm having problems to implement it on my real sheet.

I tried to reproduce my real spreadsheet with the attached new example, and you can see that after you run the macro, the items and the quantities are in different rows in the "New PO" tab. Can you help me fixing that?

Also, when I have my real spreadsheet with all the data and formulas, this macro takes around 5 seconds to complete (counter productive when going through hundreds of items). Is there a way to make it faster? I have a similar macro that copy & paste and run super fast, but it does not look at blank cells. The code is:

Sub MyAdd()
    Dim LastR As Range
    Set LastR = Sheets("new pos").Range("a" & Rows.Count).End(xlUp)(2)
    With Sheets(" P S I ")
        LastR.Resize(, 5).Value = Array(.[C6].Value, .[c7].Value, .[C31].Value, .[D31].Value, .[E31].Value)
        LastR.Range("T1").Resize(, 1).Value = Array(.[N100].Value)
        LastR.Range("AE1").Resize(, 3).Value = Array(.[N88].Value, .[N89].Value, .[N90].Value)

        .[C31:E31].ClearContents
    End With
End Sub

[WideBoyDixon]

Try this instead:

Public Sub AddItemsToList()

Dim vC As Range
Dim vD As Range
Dim nR As Long

Application.ScreenUpdating = False
nR = Worksheets("New POs").Cells(Worksheets("New POs").Rows.Count, "B").End(xlUp).Row + 1
If nR = 2 Then nR = 3
Set vC = Worksheets(" P S I ").Range("B41:Y61")
vC.AutoFilter
vC.AutoFilter Field:=23, Criteria1:="<>"
For Each vD In vC.Resize(, 1).SpecialCells(xlCellTypeVisible)
    If vD.Value <> "" Then
        Worksheets("New POs").Cells(nR, "B").Value = vD.Value
        Worksheets("New POs").Cells(nR, "C").Value = vD.Offset(0, 22).Value
        nR = nR + 1
    End If
Next vD
vC.AutoFilter
vC.Resize(, 1).Offset(0, 22).ClearContents
Application.ScreenUpdating = True

End Sub

WBD

[ricdamiani]

It's almost good, but the clear contents line is giving me error because columns X and Y are merged.

Interesting that your first macro did not have this error, so I'm wondering if it is possible to clear contents using the logic in the first code?

Thank you!

[WideBoyDixon]

Change this one line to use 2 instead of 1:

vC.Resize(, 2).Offset(0, 22).ClearContents

WBD