VBA: Copy and transpose data from one column to new row

user_14218817 0
Viewed 379

Apologies if this is has already been asked but I'm stuck. I have a sheet with data in 1 column. I need it transposed into rows. The data range is every 15 rows in the column, then new range starts. From there I need to transpose to a new sheet and new row for each range.

So like this, but every 16th row is a new data set.

Sub Macro3()

Macro3 Macro
Range("D2:E16").Select
Selection.Copy
Sheets("Tuesday").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End Sub

Any and all help and tips would be greatly appreciated.

Many thanks.

vba excel
2 Answers

Give this a try, but note that you should probably add a sheet reference for the source range otherwise you'll need to make sure the correct sheet is active when you run the code.


Sub TransposeData()
Dim rngDst As Range
Dim rngSrc As Range

    ' set reference to source range
    Set rngSrc = Range("D2:E16")
    
    ' set reference to destination range
    Set rngDst = Sheets("Tuesday").Range("B2")
    
    Do
        rngSrc.Copy
        rngDst.PasteSpecial Transpose:=True
        Set rngDst = rngDst.Offset(1)
        Set rngSrc = rngSrc.Offset(15)
    Loop Until rngSrc.Cells(1, 1).Value = ""
    
End Sub
user_28500260

Copy Transpose

  • Adjust the values in the constants section.
Option Explicit

Sub Macro3()
    
    ' Constants
    Const sName As String = "Sheet1"
    Const sAddress As String = "D2:E16"
    Const dName As String = "Tuesday"
    Const dFirst As String = "B2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Source
    
    Dim srg As Range: Set srg = wb.Worksheets(sName).Range(sAddress)
    Dim sCount As Long
    Dim cCount As Long
    Dim rCount As Long
    Dim nCount As Long
    
    With srg
        rCount = .Rows.Count
        cCount = .Columns.Count
        Dim sCell As Range
        Set sCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If sCell Is Nothing Then Exit Sub
        sCount = sCell.Row - .Row + 1
        If sCount Mod rCount = 0 Then
            nCount = sCount / rCount
        Else
            nCount = sCount / rCount + 1
        End If
    End With
    
    ' Destination
    
    Dim dcell As Range: Set dcell = wb.Worksheets(dName).Range(dFirst)
    
    ' Copy
   
    Application.ScreenUpdating = False
    
    Dim n As Long
    For n = 1 To nCount
        srg.Copy
        dcell.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=True
        Set srg = srg.Offset(rCount)
        Set dcell = dcell.Offset(cCount)
    Next n
 
    Application.ScreenUpdating = True
 
End Sub
user_98140690
Related