Transposes a contiguous range of selected cells in Excel and repeats the header rows.

TransposeOilVendorData.vb

' TRANSPOSEOILVENDORDATA.VB
' BY JOSH EINSTEIN
'
' This is an Excel VBA macro that transposes a contiguous range of selected cells in Excel
' and repeats the header rows. Created specifically for a friend of mine, so probably not
' generally useful.

' INSTRUCTIONS
' To use, select a rectangular range of cells containing the table that you want to transpose.
' The first row should include the header values across that you want to be repeated
' vertically for each table in the transposed data.

' CAUTION: If there is a sheet with the name below, it will be deleted without warning!

Const DestWorksheet As String = "Transposed"  ' the name of the new sheet that will be created
Const SourceWorksheet As String = "Current"   ' the name of the worksheet containing vendor data

Private SourceColumnStart As String    ' the column where the vendor data starts
Private SourceColumnEnd As String      ' the column where the vendor data ends
Private SourceRowCount As Long         ' the number of data rows in each section
Private SourceLastRow As Long          ' the last row # of the vendor data (so the macro knows when to stop)

Sub TransposeVendorData()

    SourceColumnStart = "A"
    SourceColumnEnd = "K"
    SourceRowCount = 5
    SourceLastRow = 66

    FigureOutSelection
    
    DeleteWorkSheet DestWorksheet

    Dim src As Worksheet: Set src = Application.Sheets(SourceWorksheet)
    Dim dst As Worksheet: Set dst = CreateWorksheet(DestWorksheet)

    ' Header will be copied to each new table
    Dim headerRange As Range: Set headerRange = src.Range(SourceColumnStart & "1:" & SourceColumnEnd & "1")

    Dim sourceColumnCount As Long: sourceColumnCount = headerRange.Columns.Count

    Dim srcR As Long: srcR = 2
    Dim dstR As Long: dstR = 1
        
    Dim srcRange As Range
    Dim dstRange As Range
    
    Do

        ' position the destination range in the next empty cell
        ' where we'll transpose a copy of the header range
        Set dstRange = dst.Cells(dstR, 1)
        
        TransposeRange headerRange, dstRange
        
        ' get the section range from the source table
        Set srcRange = src.Range(SourceColumnStart & srcR & ":" & SourceColumnEnd & srcR + (SourceRowCount - 1))
        Set dstRange = dst.Cells(dstR, 2)

        TransposeRange srcRange, dstRange
        
        ' increment our row position for the next loop iteration
        srcR = srcR + SourceRowCount
        dstR = dstR + sourceColumnCount + 1

    Loop Until srcR > SourceLastRow

    dst.Activate

End Sub

Private Sub TransposeRange(ByVal copyFrom As Range, ByVal pasteTo As Range)

    copyFrom.Copy
    pasteTo.PasteSpecial xlPasteFormulasAndNumberFormats, xlPasteSpecialOperationNone, False, True

End Sub

Private Function CreateWorksheet(ByVal name As String) As Worksheet

    Dim sheet As Worksheet: Set sheet = Application.Worksheets.Add()
    sheet.name = name
    
    Set CreateWorksheet = sheet

End Function

Private Sub DeleteWorkSheet(ByVal name As String)

    On Error Resume Next
    
    ' Prevent delete confirmation
    Application.DisplayAlerts = False
    
    ' Get reference to the named worksheet
    Dim sheet As Worksheet: Set sheet = Application.Worksheets(name)
    
    ' delete the worksheet
    If Not sheet Is Nothing Then
        sheet.Delete
    End If
        
    Application.DisplayAlerts = True

End Sub

Private Sub FigureOutSelection()

    Dim sel As Range: Set sel = Application.Selection
    
    SourceColumnStart = Mid(sel.Rows.End(xlUp).Address, 2, 1)
    SourceColumnEnd = Mid(sel.Rows.End(xlToRight).Address, 2, 1)
    SourceLastRow = sel.Rows.Count

End Sub