Can anybody please show me how to loop the following macro until a cell is empty

[Newryvidoman]

Can anybody please show me how to loop the following macro until a cell is empty in column A of Sheet("Data Sheet Copy"), thanks
The macro code below selects & copies the first rows of data (including the header) in Sheet("Data Sheet Copy") TransposePaste in an empty row of column A in Sheet("New Sheet"). I then select Sheet("Data Sheet Copy") and delete Row 2 (the row that has been copied). I have tried several code snippets but have been unsuccessful in looping this macro until a cell is empty in column A of Sheet("Data Sheet Copy")


Sub Copy_Row2_TransposePaste_Delete_Row2()

Sheets("Data Sheet Copy").Select
Range("A1:A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("NewSheet").Select
With Sheets("NewSheet")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End With
Sheets("Data Sheet Copy").Select
Application.CutCopyMode = False
Rows("2:2").Select
Selection.Delete Shift:=xlUp
ActiveCell.Offset(1, 0).Select
End Sub

[p45cal]

Doing only the necessary to alter your code:
Sub Copy_Row2_TransposePaste_Delete_Row2()
Do
Sheets("Data Sheet Copy").Select
Range("A1:A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("NewSheet").Select
With Sheets("NewSheet")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Sheets("Data Sheet Copy").Select
Application.CutCopyMode = False
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Loop Until ActiveCell.Value = ""
End Sub


What you're doing is unpivoting the table. There are other ways to do this.
Supply a workbook with realistic data in and I can show you several otherways…

[Newryvidoman]

Thank you very much your help. I have attached a sample workbook.
28061

Doing only the necessary to alter your code:
Sub Copy_Row2_TransposePaste_Delete_Row2()
Do
Sheets("Data Sheet Copy").Select
Range("A1:A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("NewSheet").Select
With Sheets("NewSheet")
lst = .Range("A" & Rows.Count).End(xlUp).Row + 1
.Range("A" & lst).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End With
Sheets("Data Sheet Copy").Select
Application.CutCopyMode = False
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Loop Until ActiveCell.Value = ""
End Sub


What you're doing is unpivoting the table. There are other ways to do this.
Supply a workbook with realistic data in and I can show you several otherways…

[Newryvidoman]

The table of customers and food products orders. This table changes every week.
I want to make order lists/invoices for each customer
I have decided to try the DO loop, it works, thank you p45cal
Please find table sample with macro attached

[p45cal]

You seem to have row headers as well as column headers.
Is this is fact the sort of thing you're looking for?:
28062
If not, try just adding any text in cell A1 of the Data Sheet Copy sheet and run the macro. Is the result on NewSheet what you really want?
If that isn't what you want either, add a sheet to your attached file showing us what you actually want to see on NewSheet.