VBA - Copy to Master List; Question with Loop / Cleaning up Code

[ElRugg]

Hi all, I'm fairly new at this and most of what I've learned has been cobbled together from Google searches. I was able to work together a code that does what I need it to do, but thinking there has to be a shorter and easier way to do the same thing.

I have a form worksheet "PO Form" for Purchase Orders including info such as a Purchase Order #, Vendor name, item #, item description, quantity, cost. I want to copy the information from the form into a worksheet to create basically a master list of all the items with one row per item. I've attached 2 pictures showing what each worksheet looks like. Where I'm having issues is that there can be multiple items on one purchase order but each item has to refer to the same PO and vendor.

So here's what I have for the first line item:

Sheets("PO Form").Select
    Range("B17").Select
    Selection.Copy
    Sheets("PO List").Select
    Range("E1").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
    Range("B4").Select
    Selection.Copy
    Sheets("PO List").Select
    Selection.End(xlToLeft).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
   Range("B3").Select
   Selection.Copy
   Sheets("PO List").Select
   ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
   Range("B6").Select
   Selection.Copy
   Sheets("PO List").Select
   ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
   Range("a17").Select
   Selection.Copy
   Sheets("PO List").Select
   ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
   Range("c17").Select
   Selection.Copy
   Sheets("PO List").Select
   ActiveCell.Offset(0, 2).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
 
Sheets("PO Form").Select
   Range("d17").Select
   Selection.Copy
   Sheets("PO List").Select
   ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

and then for each additional line in the range of possible items, I have it set up as an "If" so that nothing is copied if there's only 1 item but does copy everything if there's additional items:

Sheets("PO Form").Select
   Range("B18").Select 
 
If IsEmpty(ActiveCell) Then
Else


End If

Where below Else, I basically have it copied from above. Between the long string of copying and then a long string of ranges B18:B30 (for the different line items), it's a really lengthy code.

I'm thinking there has to be a way to use loop to shorten this, and probably also ways to clean it up. The code I have now does what I want so I could leave it as is but in part for my own knowledge, help would be appreciated!

Any other info I could provide, let me know!

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub ElRugg()
   Dim NxtRw As Long
   Dim Ws As Worksheet
   
   Set Ws = Sheets("PO List")
   NxtRw = Ws.Range("E" & Rows.Count).End(xlUp).Offset(1).Row
   
   With Sheets("PO Form")
      If .Range("B18").Value = "" Then
         .Range("A17:E17").Copy Ws.Range("D" & NxtRw)
         Rws = 1
      Else
         Rws = .Range("B17").End(xlDown).Row - 16
         .Range("A17").Resize(Rws, 5).Copy Ws.Range("D" & NxtRw)
      End If
      .Range("B4").Copy Ws.Range("A" & NxtRw).Resize(1 * Rws)
      .Range("B3").Copy Ws.Range("B" & NxtRw).Resize(1 * Rws)
      .Range("B6").Copy Ws.Range("C" & NxtRw).Resize(1 * Rws)
   End With
End Sub

 

[ElRugg]

Closer! 2 things though:

- I was using paste formulas to keep the formatting of the PO List spreadsheet rather than the formatting from the Form.

- I didn't need column E copied, although that doesn't matter much.

Thanks so much!

 

[Fluff]

Ok, how about

Sub ElRugg()
   Dim NxtRw As Long, Rws As Long
   Dim Ws As Worksheet
   
   Set Ws = Sheets("PO List")
   NxtRw = Ws.Range("E" & Rows.Count).End(xlUp).Offset(1).Row
   
   With Sheets("PO Form")
      If .Range("B18").Value = "" Then
         Ws.Range("D" & NxtRw).Resize(, 4).Value = .Range("A17:D17").Value
         Rws = 1
      Else
         Rws = .Range("B17").End(xlDown).Row - 16
         Ws.Range("D" & NxtRw).Resize(Rws, 4).Value = .Range("A17").Resize(Rws, 4).Value
      End If
      Ws.Range("A" & NxtRw).Resize(, 3).Value = Array(.Range("B4").Value, .Range("B3").Value, .Range("B6").Value)
      Ws.Range("A" & NxtRw).Resize(Rws, 3).FillDown
   End With
End Sub

 

[ElRugg]

Perfect! Thanks again!

 

[Fluff]

You're welcome & thanks for the feedback.

 

[ElRugg]

Alright, so having used this for a few weeks, it unfortunately isn't doing what I want it to every time.

I need it to copy the date, Po # and company from the form sheet to the list, and sometimes it does that. Other times it just shows the same info as the line above it. I'm not sure why sometimes it's right and other times it's not. Any idea to help?

 

[Fluff]

Can you please post some sample data using the XL2BB add-in.

 

[ElRugg]

I haven't used the XL2BB add in before so I hope this works. Let me know if not:

This is the PO Form to be copied:

PO Database.xlsm
	A	B	C	D	E
1	Purchase Order
2
3	PO Number:	27049
4	Date:	7/17/2020
5
6	Vendor:	Enter Vendor	Ship To:
7
8
9
10
11
12
13	Shipping Method	Shipping Terms	Job Name / Reference
14			Test
15
16	Item Number	Description	Quantity	Unit Price	Line Total
17	Test	Test	1	$2.00	$2.00
18
19
20
21
22
23
24
25
26
27
28
29
30
31				Subtotal	$2.00
32	Comments:			Tax
33				Shipping
34				Total	$2.00
35
36
37	Authorized By:		Date:
PO Form

Cell Formulas
Range	Formula
A14	A14	=IFERROR(VLOOKUP(B6, Vendor,8, FALSE),"")
B14	B14	=IFERROR(VLOOKUP(B6, Vendor,9, FALSE),"")
E30,E17:E28	E17	=C17*D17
E31	E31	=SUM(E17:E30)
E34	E34	=SUM(E31:E33)

This is the page PO List page. Row 2 was entered previously. Row 3 is where the info matching the PO form should be copying. As you should be able to see in A3:C3, it's showing the data from the above row rather than the new form data.

PO Database.xlsm
	A	B	C	D	E	F	G
1	PO Date	PO #	Vendor	Item #	Item Description	Qty	Cost/Item
2	7/16/20	27048	Amazon		2 Items: requested by Ted
3	7/16/20	27048	Amazon	Test	Test	1	$2.00
PO List

Thanks!

 

[Fluff]

Ok thanks for that, make this change

      ws.Range("A" & NxtRw).Resize(, 3).Value = Array(.Range("B4").Value, .Range("B3").Value, .Range("B6").Value)
      If Rws > 1 Then ws.Range("A" & NxtRw).Resize(Rws, 3).FillDown
   End With