Copy in group of 11, transpose, repeat until hit a blank cell

[whataslacker]

I am getting data from a web source that is putting all the information into the first column. I need to be able to copy and transpose that information from that sheet into a new one then be able to repeat it for the next set of 11 rows until I hit a blank row in column A

This is the basic macro but I know there are ways to repeat it and increment it by 11. I just can't seem to find my particular solution anywhere. And right now I would be stuck making macros for every group of 11 I need transposed (then I might as well do it manually).

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("A1:A11").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

Sub Macro2()
'
' Macro2 Macro
'

'
    Range("A12:A22").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub whataslacker()
   Dim i As Long, j As Long
   
   j = 1
   With Sheets("Sheet1")
      For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row Step 11
         j = j + 1
         Sheets("Sheet2").Range("A" & j).Resize(, 11).Value = Application.Transpose(.Range("A" & i).Resize(11).Value)
      Next i
   End With
End Sub

 

[Norie]

Here are 2 sets of code to do the transposing, the first one will copy and paste special all and the second will only copy values.

Sub Transpose11All()
Dim rngDst As Range
Dim rngSrc As Range
    
    Application.ScreenUpdating = False
    
    Set rngSrc = Sheets("Sheet1").Range("A1:A11")
    Set rngDst = Sheets("Sheet2").Range("A2")
    
    Do
        rngSrc.Copy
        rngDst.PasteSpecial xlPasteAll, Transpose:=True
        Set rngDst = rngDst.Offset(1)
        Set rngSrc = rngSrc.Offset(11)
    Loop Until rngSrc.Cells(1, 1).Value = ""
    
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
End Sub



Sub Transpose11Value()
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim cnt As Long
Dim idxCol As Long
Dim idxRow As Long

    arrDataIn = Sheets("Sheet3").Range("A1").CurrentRegion
   
    ReDim arrDataOut(1 To Int((UBound(arrDataIn, 1)) / 11) + 1, 1 To 11)
   
    For idxRow = LBound(arrDataIn, 1) To UBound(arrDataIn, 1) Step 11
        cnt = cnt + 1
        For idxCol = 1 To 11
            If idxRow + idxCol - 1 <= UBound(arrDataIn, 1) Then
                arrDataOut(cnt, idxCol) = arrDataIn(idxRow + idxCol - 1, 1)
            End If
        Next idxCol
    Next idxRow
   
    Sheets("Sheet2").Range("A2").Resize(UBound(arrDataOut, 1), UBound(arrDataOut, 2)).Value = arrDataOut
   
End Sub

 

[mumps]

Try:

Sub transposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, x As Long, desWS As Worksheet
    Set desWS = Sheets("Sheet2")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = 1 To LastRow Step 11
        Cells(x, 1).Resize(11).Copy
        desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Transpose:=True
    Next x
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[whataslacker]

Thanks! I will give these a try and report back how they go.

 

[whataslacker]

Try:

Sub transposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, x As Long, desWS As Worksheet
    Set desWS = Sheets("Sheet2")
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For x = 1 To LastRow Step 11
        Cells(x, 1).Resize(11).Copy
        desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Transpose:=True
    Next x
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

First one I tried and it worked! Thank you all.
Still going to try the others and then try and figure out what is happening where. I want to learn how to do this not just copy your work. Thanks again.

 

[mumps]

Glad to help.

 

[whataslacker]

Here are 2 sets of code to do the transposing, the first one will copy and paste special all and the second will only copy values.

Sub Transpose11All()
Dim rngDst As Range
Dim rngSrc As Range
   
    Application.ScreenUpdating = False
   
    Set rngSrc = Sheets("Sheet1").Range("A1:A11")
    Set rngDst = Sheets("Sheet2").Range("A2")
   
    Do
        rngSrc.Copy
        rngDst.PasteSpecial xlPasteAll, Transpose:=True
        Set rngDst = rngDst.Offset(1)
        Set rngSrc = rngSrc.Offset(11)
    Loop Until rngSrc.Cells(1, 1).Value = ""
   
    Application.CutCopyMode = False
   
    Application.ScreenUpdating = True
   
End Sub



Sub Transpose11Value()
Dim arrDataIn As Variant
Dim arrDataOut As Variant
Dim cnt As Long
Dim idxCol As Long
Dim idxRow As Long

    arrDataIn = Sheets("Sheet3").Range("A1").CurrentRegion
  
    ReDim arrDataOut(1 To Int((UBound(arrDataIn, 1)) / 11) + 1, 1 To 11)
  
    For idxRow = LBound(arrDataIn, 1) To UBound(arrDataIn, 1) Step 11
        cnt = cnt + 1
        For idxCol = 1 To 11
            If idxRow + idxCol - 1 <= UBound(arrDataIn, 1) Then
                arrDataOut(cnt, idxCol) = arrDataIn(idxRow + idxCol - 1, 1)
            End If
        Next idxCol
    Next idxRow
  
    Sheets("Sheet2").Range("A2").Resize(UBound(arrDataOut, 1), UBound(arrDataOut, 2)).Value = arrDataOut
  
End Sub

First one worked for me but on the second one I was getting a runtime error. But that is okay since the first one works.

 

[whataslacker]

Hi & welcome to MrExcel.
How about

Sub whataslacker()
   Dim i As Long, j As Long
  
   j = 1
   With Sheets("Sheet1")
      For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row Step 11
         j = j + 1
         Sheets("Sheet2").Range("A" & j).Resize(, 11).Value = Application.Transpose(.Range("A" & i).Resize(11).Value)
      Next i
   End With
End Sub

And this one works as well. Three good working solutions. Now to learn what you all did to make this happen. Thanks again! Huge help to this newbie.

 

[Fluff]

Glad we could help & thanks for the feedback.