Create 1 new list from 4 changing length columns

[billybowen]

Hi all, i have 4 equal columns of names A-D and in E i have the number of rows with names in the columns which changes, im looking to create a new list in F containing all 4 columns names without spaces accounting for the length of column changes, help much appreciated.

 

[mole999]

Sub DoIt()
    Dim LastRow As Long
    Dim LastRowB As Long
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    LastRowB = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    ActiveSheet.Range("A2:A" & LastRow).Copy Destination:=ActiveSheet.Range("E2")
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
    LastRowB = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    ActiveSheet.Range("B2:B" & LastRow).Copy Destination:=ActiveSheet.Range("E" & LastRowB + 1)
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
    LastRowB = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    ActiveSheet.Range("C2:C" & LastRow).Copy Destination:=ActiveSheet.Range("E" & LastRowB + 1)
    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "D").End(xlUp).Row
    LastRowB = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    ActiveSheet.Range("D2:D" & LastRow).Copy Destination:=ActiveSheet.Range("E" & LastRowB + 1)
    LastRowB = ActiveSheet.Cells(ActiveSheet.Rows.Count, "E").End(xlUp).Row
    Range("E2:E" & LastRowB).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("E2:E" & LastRowB) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("E2:E" & LastRowB)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub