Transpose multiple text-based columns to single column while retaining record ids

SchoobsVT,

Welcome to the Excel Forum.

Can you add to your workbook a new worksheet with the new format you are looking for (say, for at least two records)?

Click on the New Post button, then scroll down and see Manage Attachments.

run the macro and it will reformat and place the data on sheet2

It works on the size of the used area of sheet1. So it readjusts to what you have got.

The only issue might be if your rows x columns was greater than the maximum size of a sheet.


PS the best way to say thanks is to click on the "scales" icon (next to the red triangle) on any post you find helpful.

This should do it, it's not fast, but it does the work:

Option Explicit

Sub RowFormatColumnData()
Dim Faults As Range
Dim LastRw As Long, Rw As Long
Application.ScreenUpdating = False

LastRw = Range("A" & Rows.Count).End(xlUp).Row

For Rw = LastRw To 2 Step -1
    Set Faults = Range(Cells(Rw, "D"), Cells(Rw, Columns.Count).End(xlToLeft))
    If Faults.Cells.Count > 1 Then
        Range("D" & Rw + 1).Resize(Faults.Cells.Count - 1, 1).EntireRow.Insert xlShiftDown
        With Faults.Resize(1, Faults.Cells.Count - 1).Offset(0, 1)
            .Copy
            Range("D" & Rw + 1).PasteSpecial xlPasteAll, Transpose:=True
            .ClearContents
        End With
    End If
Next Rw

With Columns("A:C")
    .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    .Value = .Value
End With

Range("E1", Range("E1").End(xlToRight)).Clear
Range("D1") = "Fault"
Range("A2").Select
Range("A1").CurrentRegion.Columns.AutoFit
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
End Sub