Convert Multiple Columns to Rows including blank cells

Hello BJPhil,

Here is another version of the workbook. This version has the data to be converted on "Sheet1", the source, and the results are output to "Sheet2", the destination. The button to run the macro has been moved to "Sheet2" also.

New Macro

Sub Macro1()

  ' Thread: http://www.excelforum.com/excel-programming-vba-macros/1003920-convert-multiple-columns-to-rows-including-blank-cells.html
  
    Dim c       As Long
    Dim Data    As Variant
    Dim n       As Long
    Dim r       As Long
    Dim Rng     As Range
    Dim Who     As String
    Dim SrcWks     As Worksheet
    
        Set SrcWks = Worksheets("Sheet1")
        
        Set DstWks = Worksheets("Sheet2")
        
            Set Rng = SrcWks.Range("A1").CurrentRegion
        
            n = (SrcWks.Cells(1, Columns.Count).End(xlToLeft).Column - 1) / 4

            r = Rng.Rows.Count - 1
            ReDim Data(1 To (r * n), 1 To 5)
            n = 1
            
                For r = 2 To Rng.Rows.Count
                    Who = Rng.Cells(r, 1)
                    
                    For c = 2 To Rng.Columns.Count Step 4
                        Data(n, 2) = Rng.Cells(r, c + 0)
                        Data(n, 3) = Rng.Cells(r, c + 1)
                        Data(n, 4) = Rng.Cells(r, c + 2)
                        Data(n, 5) = Rng.Cells(r, c + 3)
                        
                        x = Application.Match("*", Array(Data(n, 2), Data(n, 3), Data(n, 4), Data(n, 5)), 0)
                        If Not IsError(x) Then
                            Data(n, 1) = Who
                            n = n + 1
                        End If
                    Next c
                Next r
            
            DstWks.UsedRange.Offset(1, 0).ClearContents
            DstWks.Cells(2, "A").Resize(UBound(Data), 5).Value = Data
            
End Sub