Transpose Batch Excel Data

Just in case you want a different option, here is a code process:

Option Explicit


Sub TransformROWSTOCOL()

Dim rsht1 As Long, rsht2 As Long, i As Long, Col As Long
Dim wsTest As Worksheet, mr As Worksheet, ms As Worksheet
Dim c As Range

'check if sheet "ouput" already exist

Const strSheetName As String = "Transform"

Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
 
If wsTest Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If

'set the data
                 
Set mr = Sheets("Original Data") 'this is the name of the source sheet
Set ms = Sheets("Transform")     'this is the name of the destiny sheet
Col = 5
'End set the data
    With ms
     .UsedRange.ClearContents
     .Range("A1:D1").Value = Array("Origin City", "Origin State", "Destination City", "Destination State")
    End With
    rsht2 = ms.Range("A" & Rows.Count).End(xlUp).Row
    With mr
          rsht1 = .Range("A" & .Rows.Count).End(xlUp).Row
          For i = 2 To rsht1
                Do While .Cells(1, Col).Value <> ""
                rsht2 = rsht2 + 1
                ms.Range("A" & rsht2).Value = .Range("A" & i).Value
                ms.Range("B" & rsht2).Value = .Range("B" & i).Value
                ms.Range("C" & rsht2).Value = .Range("C" & i).Value
                ms.Range("D" & rsht2).Value = .Range("D" & i).Value
                ms.Range("E" & rsht2).Value = .Cells(1, Col).Value
                ms.Range("F" & rsht2).Value = .Cells(2, Col).Value
                ms.Range("G" & rsht2).Value = .Cells(i, Col).Value
                
                Col = Col + 1
            Loop
            Col = 2
        Next
    End With
    
  With ms
    .Range("F2:F" & .Rows.Count).SpecialCells(Type:=xlCellTypeBlanks).EntireRow.Delete
    .Columns("A:D").EntireColumn.AutoFit
    End With
    
End Sub

Originally Posted by maniacb

Just in case you want a different option, here is a code process:

Option Explicit


Sub TransformROWSTOCOL()

Dim rsht1 As Long, rsht2 As Long, i As Long, Col As Long
Dim wsTest As Worksheet, mr As Worksheet, ms As Worksheet
Dim c As Range

'check if sheet "ouput" already exist

Const strSheetName As String = "Transform"

Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
 
If wsTest Is Nothing Then
    Worksheets.Add.Name = strSheetName
End If

'set the data
                 
Set mr = Sheets("Original Data") 'this is the name of the source sheet
Set ms = Sheets("Transform")     'this is the name of the destiny sheet
Col = 5
'End set the data
    With ms
     .UsedRange.ClearContents
     .Range("A1:D1").Value = Array("Origin City", "Origin State", "Destination City", "Destination State")
    End With
    rsht2 = ms.Range("A" & Rows.Count).End(xlUp).Row
    With mr
          rsht1 = .Range("A" & .Rows.Count).End(xlUp).Row
          For i = 2 To rsht1
                Do While .Cells(1, Col).Value <> ""
                rsht2 = rsht2 + 1
                ms.Range("A" & rsht2).Value = .Range("A" & i).Value
                ms.Range("B" & rsht2).Value = .Range("B" & i).Value
                ms.Range("C" & rsht2).Value = .Range("C" & i).Value
                ms.Range("D" & rsht2).Value = .Range("D" & i).Value
                ms.Range("E" & rsht2).Value = .Cells(1, Col).Value
                ms.Range("F" & rsht2).Value = .Cells(2, Col).Value
                ms.Range("G" & rsht2).Value = .Cells(i, Col).Value
                
                Col = Col + 1
            Loop
            Col = 2
        Next
    End With
    
  With ms
    .Range("F2:F" & .Rows.Count).SpecialCells(Type:=xlCellTypeBlanks).EntireRow.Delete
    .Columns("A:D").EntireColumn.AutoFit
    End With
    
End Sub

Thank you. This does provide me with another option as I have to do a bunch of these every month. I appreciate you taking the time to respond!