Select range and then transpose to a new worksheet

Hello

I have a large data set (40 000 rows) and what I am trying to do is to create a macro that will select the first 72 rows of data (starting from B12 in this case), and then transpose it to another worksheet. Then the next 72 rows will be selected and transposed directly below the first block of data, and so on until all 40 000 rows have been tranposed, 72 rows at a time.

The blocks of data that I want to select are 72 rows by 26 columns, and so when they are tranposed they become 26 rows with 72 columns.
Think of the data set as 40 000 continous rows, with data for each case occupying 72 rows, so in essence every 72 rows represents one case. I want to transpose this data one case at a time into a new work book.

I have written the following macro (my macro skills are quite basic as you can see), it works nicely, except that I have to specify the code for each block. I need to incorporate some kind of loop that automatically moved the target range down 72 rows each time, and the paste cell for the transpose down 26 rows each time in the new work book. From the macro you can see that the first target data range starts is B12:AA83, and we go from there....

 Datasort Macro

'Copy data block 1'

    Sheets("Sheet").Select
    Range("B12:AA83").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
      
      '2
    Sheets("Sheet").Select
    Range("B84:AA155").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D28").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    '3
    Sheets("Sheet").Select
    Range("B156:AA227").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D54").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    '4
    Sheets("Sheet").Select
    Range("B228:AA299").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D80").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    '5
    Sheets("Sheet").Select
    Range("B300:AA371").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D106").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
     '6
    Sheets("Sheet").Select
    Range("B372:AA443").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("D132").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

As you can see it works but so far it only covers 443 rows, i would need to repeat this about another 90 times to cover all the 40 000 rows.

Can anyone help me with a more efficient solution?

I thank you in advance for your assistance.

PL TRY THIS CODE.

Sub TransposeData()

Dim TA, TB As Long

Application.ScreenUpdating = False
 Sheets("Sheet").Select
   Do While TA < 40000
    
    Range("B" & 12 + TB * 72 & ":AA" & 83 + TB * 72).Copy
    Sheets("Sheet1").Range("D" & 2 + TB * 26).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
   TA = 83 + TB * 72
   TB = TB + 1
   Loop
    Application.CutCopyMode = False
Application.ScreenUpdating = True

 End Sub

That code seems to work very nicely. Thank you very much. I am really grateful for your assistance!!

Thanks for compliments.
Pl mark the thread SOLVED.