Excel sheet_merger

Sub SheetMerger()
Dim objCol As Collection
Dim Sht As Worksheet
Dim newSht As Worksheet
Dim Rng As Range
Dim PT As Range
Dim theName As Name
    On Error Resume Next
    Application.DisplayAlerts = False
    For Each theName In ThisWorkbook.Names
        theName.Delete
    Next
    Worksheets("AllData").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Set objCol = New Collection
    For Each Sht In ThisWorkbook.Worksheets
        For Each Rng In Sht.Range(Sht.[a1], Sht.[a1].End(xlToRight))
            On Error Resume Next
                If Rng <> "" Then objCol.Add Rng, CStr(Rng.Value)
            On Error GoTo 0
        Next
    Next
    Set newSht = Worksheets.Add
    newSht.Name = "AllData"
    Set PT = newSht.Range("a1")
    For Each Rng In objCol
            PT.Value = Rng.Value
            ThisWorkbook.Names.Add Name:="_" & VBA.Replace(PT.Value, " ", "_"), RefersTo:=PT.EntireColumn
            Set PT = PT.Offset(0, 1)
    Next
    Set objCol = Nothing
    Set PT = newSht.Range("a2")
    For Each Sht In ThisWorkbook.Worksheets
        If Sht.Name <> newSht.Name Then
            For Each Rng In Sht.UsedRange.Columns
                With Rng
                    If .Cells(1) <> "" Then
                        ThisWorkbook.Names("_" & VBA.Replace(.Cells(1).Value, " ", "_")).RefersToRange.Cells(PT.Row).Resize(.Cells.Count - 1, 1).Value = _
                                        .Resize(.Cells.Count - 1, 1).Offset(1, 0).Value
                    End If
                End With
            Next
            Set PT = PT.Offset(Sht.UsedRange.Rows.Count - 1, 0)
        End If
    Next
End Sub