Shift column data in Excel

I have an existing Excel macro used to shift certain column data into rows. Here it is:

Sub Normalize()

    Dim arr As Variant
    Dim r As Long
    Dim c As Long
    Dim Counter As Long

    arr = ActiveSheet.UsedRange.Value

    [a1:c1].Value = Array("Date", "Store Number", "Employee Name")
    Counter = 1

    For r = 2 To UBound(arr, 1)
        For c = 3 To UBound(arr, 2) Step 2
            If arr(r, c) <> "" Then
                Counter = Counter + 1
                Cells(Counter, 1) = arr(r, 1)
                Cells(Counter, 2) = arr(r, 2)
                Cells(Counter, 3) = arr(r, c)
                Cells(Counter, 4) = arr(r, c + 1)
                Exit For
            End If

    MsgBox "Done"

End Sub

How would I modify it to achieve the expected results in the Expected Results worksheet of the attached Excel file? The "Starting File" worksheet is what I'm starting out with. I'm trying to shift each of the "From" and "To" columns ( whether there is data in them or not ) into new rows.
Columns 1 through 3 need to be copied into each of these new rows to maintain the correct relationship.  I want to wind up with 5 columns.  My worksheet starts out with 19 columns.
I have included only two rows of data in my example but in practice, there are usually many hundreds.
Who is Participating?
The attached code should do it:

Option Explicit

Sub asdgasdg()
Dim shtOrg As Worksheet, lgLastRow As Long, lgLastCol As Long, lgRowDest As Long
Dim shtDest As Worksheet, i As Long

Application.ScreenUpdating = False

Set shtOrg = ActiveSheet
Set shtDest = Sheets.Add

lgLastRow = shtOrg.Cells(Rows.Count, 1).End(xlUp).Row
lgLastCol = shtOrg.Cells(1, Columns.Count).End(xlToLeft).Column

With shtOrg
    .Range("A1:E" & lgLastRow).Copy shtDest.Cells(1, 1)
    For i = 6 To lgLastCol Step 2
        lgRowDest = shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range("A2:C" & lgLastRow).Copy shtDest.Cells(lgRowDest, 1)
        .Range("A2:B" & lgLastRow).Offset(0, i - 1).Copy shtDest.Cells(lgRowDest, 4)
    Next i
End With

shtDest.Cells(1, 1).CurrentRegion.Sort key1:=shtDest.[a1], Order1:=xlAscending, Header:=xlYes

Application.ScreenUpdating = True

End Sub

Open in new window

dbfromnewjerseyAuthor Commented:
Thank you.
Glad to help. Thanks for the grade.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.