adodb.Connection.OpenSchema(adSchemaColumns)

Option Explicit
Sub AdjustColmns()
    Dim con As Object, ColFiles As Collection, AL As Object
    Dim wb As Workbook, sh As Worksheet, r As Range
    Dim sFilePath As Variant, sColName As Variant
    Dim sFolderPath$, c$, ver$, i&, calc&, b As Boolean
    
    With Application.FileDialog(4)
        .AllowMultiSelect = False
        .InitialFileName = CreateObject("Shell.Application").Namespace(5).self.Path & "\"
        .Title = "Выберите папку с файлами"
sel:    If .Show = False Then
            If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
                GoTo sel
            Else
                Exit Sub
            End If
        End If
        sFolderPath = .SelectedItems(1) & "\"
    End With
    
    Set AL = CreateObject("system.collections.arraylist")
    Set con = CreateObject("adodb.Connection")
    Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")
    With Application
        For Each sFilePath In ColFiles
            On Error Resume Next
            .Workbooks(Replace(sFilePath, sFolderPath, "")).Save
            On Error GoTo 0
            Select Case Right(sFilePath, 1)
                Case "s": ver = "8.0"
                Case "x": ver = "12.0 xml"
                Case "m": ver = "12.0 macro"
                Case "b": ver = "12.0"
            End Select
            con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                sFilePath & ";Mode=Read;Extended Properties=""excel " & ver & ";HDR=YES;IMEX=1;"";"
            For Each sColName In con.OpenSchema(4).getrows(, , 3)
                c = Replace(sColName, "$", "")
                If Not AL.contains(c) Then AL.Add c
            Next
            con.Close
        Next
        AL.Sort
        .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual
        For Each sFilePath In ColFiles
            On Error Resume Next
            Set wb = .Workbooks(Replace(sFilePath, sFolderPath, ""))
            On Error GoTo 0
            If wb Is Nothing Then
                Set wb = .Workbooks.Open(sFilePath)
            Else
                b = True
            End If
            With wb
                For Each sh In .Sheets
                    i = 1
                    For Each sColName In AL
                        With sh.Rows(1)
                            Set r = .Find(sColName, , , xlWhole, , , False, , False)
                            If r Is Nothing Then
                    .End(xlToRight).Offset(, 1) = sColName
                    Set r = .End(xlToRight)
                            End If
                            If r.Column <> i Then
                    r.EntireColumn.Cut
                    .Columns(i).Insert Shift:=xlToRight
                            End If
                            i = i + 1
                        End With
                Next sColName, sh
                If Not b Then .Close True
            End With
            Set wb = Nothing
        Next
        .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc
    End With
    Set AL = Nothing: Set con = Nothing: Set r = Nothing: Set ColFiles = Nothing
End Sub

'---------------------------------------------------------------------------------------
' Модуль    : modFilenames
' Автор     : EducatedFool (Игорь)                    Дата: 13.04.2011
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты: http://excelvba.ru/payments
'---------------------------------------------------------------------------------------
Option Explicit
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
    Dim fso As Object

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set fso = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, fso, FilenamesCollection, SearchDeep    ' поиск
    Set fso = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef fso, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    Dim curfold As Object, fil As Object, sfol As Object
    On Error Resume Next: Set curfold = fso.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask And Left(fil.Name, 1) <> "~" Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, fso, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

Option Explicit
Sub AdjustColmns()
    Dim con As Object, ColFiles As Collection, AL As Object
    Dim wb As Workbook, sh As Worksheet, r As Range
    Dim sFilePath As Variant, sColName As Variant
    Dim sFolderPath$, c$, ver$, i&, calc&, b As Boolean
    With Application
        With .FileDialog(4) 'диалоговое окно выбора папки
            .AllowMultiSelect = False 'выбрать можно только одну папку
            .InitialFileName = CreateObject("Shell.Application").Namespace(5).self.Path & "\" 'при запуске диалога отобразить папку Мои доокументы
            .Title = "Выберите папку с файлами" 'заголовок диалогового окна
sel:        If .Show = False Then 'если папка не выбрана (закрыли или нажали Отмена)
                If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then 'запрос на повтор выбора
                    GoTo sel 'нажали Да, открываем диалоговое окно еще раз
                Else
                    Exit Sub 'нажали Нет, останавливаем выполнение макроса
                End If
            End If
            'записываем путь к выбранной папке
            sFolderPath = .SelectedItems(1) & "\"
        End With
        
        Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов
        Set con = CreateObject("adodb.Connection") 'ADODB подключение, будем его использовать для сбора заголовков столбцов
        
        'пишем в коллекцию пути всех excel книг из выбранной папки
        Set ColFiles = FilenamesCollection(sFolderPath, "*.xls*")

        'перебираем пути файлов в коллекции
        For Each sFilePath In ColFiles
            On Error Resume Next
            'если файл открыт, сохраняем его
            .Workbooks(Replace(sFilePath, sFolderPath, "")).Save
            On Error GoTo 0
            'определяем тип файла по последней букве расширения
            Select Case Right(sFilePath, 1)
                Case "s": ver = "8.0"
                Case "x": ver = "12.0 xml"
                Case "m": ver = "12.0 macro"
                Case "b": ver = "12.0"
            End Select
            'подлючаемся к файлу
            con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                sFilePath & ";Mode=Read;Extended Properties=""excel " & ver & ";HDR=YES;IMEX=1;"";"
            'перебиреаем значения поля COLUMN_NAME из схемы adSchemaColumns
            For Each sColName In con.OpenSchema(4).getrows(, , 3)
                c = Replace(sColName, "$", "")
                'если значение еще не добавлено в AL, то добавляем
                If Not AL.contains(c) Then AL.Add c
            Next
            'закрываем подключение
            con.Close
        Next
        AL.Sort 'сортируем полученный список заголовков столбцов
        .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual
        'перебираем пути файлов в коллекции
        For Each sFilePath In ColFiles
            On Error Resume Next
            'пробуем подключиться к открытой книге
            Set wb = .Workbooks(Replace(sFilePath, sFolderPath, ""))
            On Error GoTo 0
            
            If wb Is Nothing Then 'если книга не была открыта
                'открываем ее
                Set wb = .Workbooks.Open(sFilePath)
            Else
                b = True
            End If
            With wb
                
                For Each sh In .Sheets ' перебираем листы
                    i = 1
                    For Each sColName In AL 'перебираем значения из списка заголовков
                        With sh.Rows(1) ' работаем с первой строкой листа
                            'ищем заголовок
                            Set r = .Find(sColName, , , xlWhole, , , False, , False)
                            If r Is Nothing Then ' если не найдено
                    'добавляем заголовок справа
                    .End(xlToRight).Offset(, 1) = sColName
                    Set r = .End(xlToRight)
                            End If
                            If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL
                    'перемещаем столбец в нужную позицию
                    r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight
                            End If
                            i = i + 1
                        End With
                Next sColName, sh
                'если книга была открыта макросом, закрываем ее с сохранением изменений
                If Not b Then .Close True
            End With
            Set wb = Nothing
        Next
        .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc
    End With
    Set AL = Nothing: Set con = Nothing: Set r = Nothing: Set ColFiles = Nothing
End Sub

Option Explicit
Sub AdjustColmns()
    Dim AL As Object, oWsh As Worksheet, r As Range, sColName As Variant, i&, calc&
    Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0: calc = .Calculation: .Calculation = xlCalculationManual
            With ThisWorkbook 'книга, из которой запущен макрос
                For Each oWsh In .Sheets ' перебираем листы книги
                    'перебираем области диапазона непустых ячеек из первой строки листа
                    For Each r In oWsh.UsedRange.Rows(1).SpecialCells(2, 23).Areas
                        For Each sColName In r.Value 'перебираем значения из ячеек из области
                            'если значение еще не добавлено в AL, то добавляем
                            If Not AL.contains(sColName) Then AL.Add sColName
                Next sColName, r, oWsh
                AL.Sort 'сортируем полученный список заголовков столбцов
                For Each oWsh In .Sheets ' перебираем листы
                    i = 1
                    For Each sColName In AL 'перебираем значения из списка заголовков
                        With oWsh.Rows(1) ' работаем с первой строкой листа
                            'ищем заголовок
                            Set r = .Find(sColName, , , xlWhole, , , False, , False)
                            If r Is Nothing Then ' если не найдено
                    'добавляем заголовок справа
                    .End(xlToRight).Offset(, 1) = sColName
                    Set r = .End(xlToRight)
                            End If
                            If r.Column <> i Then 'если номер столбца с искомым заголовком не равен позиции заголовка в AL
                    'перемещаем столбец в нужную позицию
                    r.EntireColumn.Cut: .Columns(i).Insert Shift:=xlToRight
                            End If
                            i = i + 1
                        End With
                Next sColName, oWsh
            End With
        .ScreenUpdating = 1: .EnableEvents = 1: .Calculation = calc
    End With
    Set AL = Nothing: Set r = Nothing
End Sub