How to convert range with multiple columns into 3 columns range

[Sinuhet]

My apologies, but I need help
I would like convert a multicolumn range (schedule)

	Alan	Charles	James	Susan	Betty
11/14/2022		short day		long day	night
11/15/2022	night		short day		long day
11/16/2022		night	short day	long day

into range with just 3 columns:

Date	Shift name	Employee
11/14/2022	short day	Charles
11/14/2022	long day	Susan
11/14/2022	night	Betty
11/15/2022	night	Alan
11/15/2022	short day	James
11/15/2022	long day	Betty
11/16/2022	night	Charles
11/16/2022	short day	James
11/16/2022	long day	Susan

Days with no shift assigned to a person should not generate an extra row. The generated rows do not have to be necessary in chronological way.
Thank you very much for any help

 

[mumps]

Try this macro. The result will be placed in Sheet2. Change the sheet names (in red) to suit your needs.

Sub ConvertRange2()
    Application.ScreenUpdating = False
    Dim rng As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet, x As Long, cnt As Long, lRow As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With desWS
        .UsedRange.ClearContents
        .Range("A1").Resize(, 3) = Array("Date", "Shift Name", "Employee")
    End With
    With srcWS
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For x = 2 To lRow
            cnt = WorksheetFunction.CountA(.Rows(x)) - 1
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(cnt) = srcWS.Range("A" & x)
                For Each rng In srcWS.Range("B" & x).Resize(, lCol - 1)
                    If rng <> "" Then
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 2) = Array(rng, srcWS.Cells(1, rng.Column))
                    End If
                Next rng
            End With
        Next x
    End With
    Application.ScreenUpdating = True
End Sub

 

[Sinuhet]

Try this macro. The result will be placed in Sheet2. Change the sheet names (in red) to suit your needs.

Sub ConvertRange2()
    Application.ScreenUpdating = False
    Dim rng As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet, x As Long, cnt As Long, lRow As Long
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    With desWS
        .UsedRange.ClearContents
        .Range("A1").Resize(, 3) = Array("Date", "Shift Name", "Employee")
    End With
    With srcWS
        lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For x = 2 To lRow
            cnt = WorksheetFunction.CountA(.Rows(x)) - 1
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(cnt) = srcWS.Range("A" & x)
                For Each rng In srcWS.Range("B" & x).Resize(, lCol - 1)
                    If rng <> "" Then
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(, 2) = Array(rng, srcWS.Cells(1, rng.Column))
                    End If
                Next rng
            End With
        Next x
    End With
    Application.ScreenUpdating = True
End Sub

it works just fine! Thank you so much

 

[mumps]

You are very welcome.