I think this will do it.
Place the code in the worksheet's VBA
Option Explicit
Private Sub RollUpWorkHistory()
Dim tCol As Long
Dim xCol As Long
Dim xRow As Long
Dim lstRow As Long
Dim topRng As Range
lstRow = Range("A" & Rows.Count).End(xlUp).Row '* determine the last filled row
If lstRow <= 2 Then Exit Sub '* if the row <= 2 then no extra data
Application.EnableEvents = False
Application.ScreenUpdating = False
tCol = Cells(1, Columns.Count).End(xlToLeft).Column '* get the last filled column for the header to be repeated
Set topRng = Range(Cells(1, 2), Cells(1, tCol)) '* save the range to a variable
For xRow = 3 To lstRow '* loop starting at row 3 down
xCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1 '* determine the first empty column for the next header range
topRng.Copy Cells(1, xCol) '* copy the header range to the new column
Range(Cells(xRow, 2), Cells(xRow, tCol)).Copy Cells(2, xCol) '* copy the row data to the corresponding column
Next xRow
' Range(Cells(3, 1), Cells(lstRow, tCol)).Clear '* clear the data after completion (remove the ' in front to activate)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Option Explicit
Private Sub RollUpEducationHistory()
Dim tCol As Long
Dim xCol As Long
Dim xRow As Long
Dim lstRow As Long
Dim topRng As Range
lstRow = Range("A" & Rows.Count).End(xlUp).Row '* determine the last filled row
If lstRow <= 2 Then Exit Sub '* if the row <= 2 then no extra data
Application.EnableEvents = False
Application.ScreenUpdating = False
tCol = Cells(1, Columns.Count).End(xlToLeft).Column '* get the last filled column for the header to be repeated
Set topRng = Range(Cells(1, 2), Cells(1, tCol)) '* save the range to a variable
For xRow = 3 To lstRow '* loop starting at row 3 down
xCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1 '* determine the first empty column for the next header range
topRng.Copy Cells(1, xCol) '* copy the header range to the new column
Range(Cells(xRow, 2), Cells(xRow, tCol)).Copy Cells(2, xCol) '* copy the row data to the corresponding column
Next xRow
' Range(Cells(3, 1), Cells(lstRow, tCol)).Clear '* clear the data after completion (remove the ' in front to activate)
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Bookmarks