Sub foo()
    Dim lCount As Long
    Dim lCols As Long
    Dim lRows As Long
    Dim l As Long
    Dim v As Variant
    Dim ws As Worksheet
    Dim c As Range
    Dim dic As Object
    
    For Each ws In ThisWorkbook.Worksheets
        Set dic = CreateObject("Scripting.Dictionary")
        With ws
            Do Until .UsedRange.Rows(1).Row = 1
                .Rows(1).EntireRow.Delete
            Loop
            Set c = .Range("A1")
            v = c.Value
            Do Until v <> ""
                Set c = c.Offset(0, 1)
                v = c.Value
            Loop
            lCount = Application.CountIf(.UsedRange.Rows(1), v)
            lCols = .UsedRange.Rows(1).Find(what:=v, After:=c).Column - c.Column
            Set c = Nothing
            For l = 1 To lCols * lCount Step lCols
                Set c = .UsedRange.Columns(l).Find(what:="Total", LookAt:=xlPart)
                If c Is Nothing Then Set c = .UsedRange.Columns(l).Find(what:="* Estimated", LookAt:=xlPart)
                If c Is Nothing Then Set c = .UsedRange.Cells(.UsedRange.Rows.Count, 1).Offset(1, 0)
                If Not c Is Nothing Then
                    lRows = c.Row - 2
                    .Cells(2, l).Resize(lRows, lCols).Sort Key1:=.Cells(2, l), Order1:=xlAscending, Header:=xlNo
                    For Each c In .Cells(2, l).Resize(lRows, 1)
                        If c.Value <> "" Then dic(c.Value) = c.Value
                    Next c
                End If
            Next l

            Set dic = SortDic(dic)

            For l = 1 To lCols * lCount Step lCols
                For lRows = 0 To dic.Count - 1
                    With .Cells(lRows + 2, l)
                        If Not .Value = dic.items()(lRows) Then
                            .Resize(1, lCols).Insert shift:=xlDown
                        End If
                    End With
                Next lRows
            Next l
        End With
        Set dic = Nothing
    Next ws
End Sub


Public Function SortDic(dic As Object) As Object
    Dim s() As String
    Dim v As Variant
    Dim i As Integer
    Dim j As Integer

    If dic.Count > 1 Then

        ReDim s(dic.Count)
        i = 0
        For Each v In dic
            s(i) = v
            i = i + 1
        Next

        For i = 0 To (dic.Count - 2)
            For j = (i + 1) To (dic.Count - 1)
                If s(i) > s(j) Then
                    v = s(j)
                    s(j) = s(i)
                    s(i) = v
                End If
            Next
        Next

        Set SortDic = CreateObject("Scripting.Dictionary")
        For i = 0 To (dic.Count - 1)
            SortDic.Add s(i), dic(s(i))
        Next
    Else
        Set SortDic = dic
    End If
End Function