Macro to copy & paste with a loop and have it stored as a seperate excel file

[Apopolis]

Hi all,

First off, love the website which I just found and enjoy the extensive help and detailed topics on how to exel in excel :P.

I hope someone would be able to make my day with this issue I am having.

Background
This query is coming from my work area where we have multiple customers fill in an order form (excel) on a weekly basis. These orders are collected in 1 table (picture 1).
Where as;
Row 2 holds headers and basic information (static information).
Row 3 till ? are being filled with 1 order per row, but can consist of multiple items to be placed (starting from Column K:BP)

The idea now is to translate this data into a new table which we can use to upload it into our ordering system. However this table has a different layout on the actual data and thus we need to translate table 1(complete list of orders) to table 2(uploadsheet).

Let me explain the way the lists are build:

Complete list of Orders: (picture 1) TAB: "Master"
Row 2: Header information which needs to be used for the uploadsheet and their respective position in the sheet:
Column A: Order number of the customer
Column B: Loadingdate: DD.MM.YYYY
Column D: Customer number
Column K to BP: Product number

Uploadsheet: (picture 2)
Row 1: Header information (static information)
Row 2 till ?, per row the order information but then per row one product code and ordered quantity. Meaning 1 row of the list of orders can become a whole lst of rows due to the amount of products a customer places.
Where as the;
1. Order number is filled in Column E
2. Customer number is filled in Column H
3. Loading date is filled in Column J
4. Product code is filled in Column P
5 Order Quantity is filled in Column Q

*made a type in H3 which should read as "33333".

IDEA:
Now the idea I had was to have a macro that will open a new excel file which would create the needed translation of table 1 into table 2 and prompt the user to save it on the location of their choosing. However I have no idea how to do this. Also the translation of a single row order to an order consisting of multiple rows and only to copy the header and quantity filled in (and not the empty rows) remains an issue.

I searched the forum but couldn't find anything on this. Could someone help me with the coding of this idea?

Many thanks for your help and time in reading this.

Apopolis

 

[rpaulson]

try these 2 macros (untested)

Sub Create_upload()

Dim rs As Worksheet
Set rs = Worksheet("Upload")

lr = Cells(Rows.Count, "A").End(xlUp).Row
wr = 2 'row numbet to start writing the data to

For r = 3 To lr
For c = 11 To 86 ' columns K:BP

If Cells(r, c) > 0 Then 'Quanitiy is greate then zero ro write a line of data

rs.Cells(wr, "E") = Cells(r, "A")
rs.Cells(wr, "H") = Cells(r, "D")
rs.Cells(wr, "J") = Cells(r, "B")

rs.Cells(wr, "P") = Cells(2, c)
rs.Cells(wr, "Q") = Cells(r, c)

wr = wr + 1
End If
Next c

Next r
rs.Activate
End Sub

Sub Create_File()

myPath = Environ("USERPROFILE") & "\Desktop\"

myfile = InputBox("enter File name")
If myfile = "" Then Exit Sub

myfile = myPath & myfile & ".xls"

lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:Q" & lr).Copy

  Set NewBook = Workbooks.Add
  
  NewBook.Worksheets("Sheet1").Range("A1").Select
     
    ActiveSheet.Paste
  
NewBook.SaveAs Filename:=myfile
ActiveWorkbook.Close
End Sub

 

[rpaulson]

oops
Set rs = Worksheet("Upload")

should be
Set rs = Worksheets("Upload")

 

[Apopolis]

Thank you @rpaulson it works as a charm!

 

[rpaulson]

your welcome

 

[Apopolis]

your welcome

I spoke too soon

The create file macro takes (copies) the data from the "Master" sheet instead of the Upload sheet and only the first 2 rows.

Would it also be possible to have the data (not formulas) deleted after the file has been created?

Many thanks in advance for helping me on this!!!

 

[rpaulson]

this should save the correct file

Sub Create_File()

myPath = Environ("USERPROFILE") & "\Desktop\"

myfile = InputBox("enter File name")
If myfile = "" Then Exit Sub

myfile = myPath & myfile & ".xls"

Dim rs As Worksheet
Set rs = Worksheets("Upload")


lr = rs.Cells(Rows.Count, "A").End(xlUp).Row
rs.Range("A1:Q" & lr).Copy

Set NewBook = Workbooks.Add
 
NewBook.Worksheets("Sheet1").Range("A1").Select
     
ActiveSheet.Paste
 
NewBook.SaveAs Filename:=myfile
ActiveWorkbook.Close
End Sub

 

[Apopolis]

Thank you so much @rpaulson !!!!