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

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")

Code:

---

Sub Copy_Row2_TransposePaste_Delete_Row2()

---

Code:

---

    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

---

Doing only the necessary to alter your code:

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…

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

Quote:

---

Originally Posted by p45cal

Doing only the necessary to alter your code:

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…

---

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

You seem to have row headers as well as column headers.
Is this is fact the sort of thing you're looking for?:
Attachment 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.