What is the most efficient way to copy, paste and transpose values between worksheets?

Hi guys.

I would like to move the ranges that are highlighted in yellow to the second sheet. NB! The coloring is only there to help you see what part I want to move. I don't want a search for yellow cells.

I also want the ranges to be transposed and form one continuous range.

Here is the code I have written. It works fine, but it's incredibly slow.

Sub CopyMove1()
    
    Dim i As Long
    
    For i = 5 To 719 Step 14
    
        Worksheets(1).Activate
    
        Range(Cells(i, 2), Cells(i + 7, 8)).Select
        
        Selection.Copy
        
        Worksheets(2).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        
    Next i
      
End Sub

I was wondering what you guys think is the "best" or most efficient way to perform the task at hand?

Also, if you have any tips or suggestions related to copying and pasting I would love to hear it. Don't be shy!

If my explanation wasn't clear enough (probably wasn't) then just run the macro and you will see what I mean.

Thanks a bunch!

It can be done, but need clarification.
The Uk heading starting at the top goes all the way down. When you say transpose, do all the data go on the same sheet in sequence. You have three sheets, so I do not know what would be the relevant of these sheets.

Originally Posted by AB33

It can be done, but need clarification.
The Uk heading starting at the top goes all the way down.

Yes, I would like the macro to collect all the ranges. PS. "Uke" means week

Originally Posted by AB33

When you say transpose, do all the data go on the same sheet in sequence. You have three sheets, so I do not know what would be the relevant of these sheets.

Yes, all on the same page. In my macro above, I put all of them in Sheet(2)

Thank you for your time!

Try this one

Sub test()
 Dim ms As Worksheet, LR&, i&, j&

  Set ms = Sheets("Ark2")
  With Sheets("Ark1")
 
     LR = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    For i = 4 To LR
        If InStr(.Cells(i, 2), "Man") > 0 Then
        j = Application.Match("Sum", .Range("A:A"), 0)
        Range(.Cells(i + 1, 2), .Cells(i + 1, 8)).Resize(j - 5).Copy
        ms.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues, Transpose:=False
        End If
   Next
 End With
End Sub

Thanks AB33.

It's great to see different approaches on things.

You are welcome!