Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Приведение столбцов в таблицах к одному виду - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Приведение столбцов в таблицах к одному виду (Макросы/Sub)
Приведение столбцов в таблицах к одному виду
Raid Дата: Воскресенье, 20.01.2019, 00:07 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Уважаемые знатоки. Есть книга, в ней несколько листов. В каждой книге таблица с столбцами подписаными по первой строке.
Столбцы могут повторятся на другом листе, могут быть уникальны для всей книги
Нужно сделать так, что бы все таблицы (листы) были содержали одинаковые столбцы (нужно восполнить на каждом листе недостающие). Причем в результате последовательность столбцов должна быть идентичной на кажом листе.
Если в листе нет данного столбца - он вставляется с нулевыми (пустыми) значениями ячеек ниже первой
К сообщению приложен файл: 9497543.xlsx(10.2 Kb)
 
Ответить
СообщениеУважаемые знатоки. Есть книга, в ней несколько листов. В каждой книге таблица с столбцами подписаными по первой строке.
Столбцы могут повторятся на другом листе, могут быть уникальны для всей книги
Нужно сделать так, что бы все таблицы (листы) были содержали одинаковые столбцы (нужно восполнить на каждом листе недостающие). Причем в результате последовательность столбцов должна быть идентичной на кажом листе.
Если в листе нет данного столбца - он вставляется с нулевыми (пустыми) значениями ячеек ниже первой

Автор - Raid
Дата добавления - 20.01.2019 в 00:07
vikttur Дата: Воскресенье, 20.01.2019, 00:49 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2921
Репутация: 525 ±
Замечаний: 0% ±

Список уникальных сможете создать? С этим намного проще.
Иначе придется сначала бежать по всем книгам (открыть/считать/закрыть)
 
Ответить
СообщениеСписок уникальных сможете создать? С этим намного проще.
Иначе придется сначала бежать по всем книгам (открыть/считать/закрыть)

Автор - vikttur
Дата добавления - 20.01.2019 в 00:49
krosav4ig Дата: Воскресенье, 20.01.2019, 04:19 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 2033
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
vikttur, бежать можно и окольными путями, не отрывая каждый, [vba]
Код
adodb.Connection.OpenSchema(adSchemaColumns)
[/vba],например


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщениеvikttur, бежать можно и окольными путями, не отрывая каждый, [vba]
Код
adodb.Connection.OpenSchema(adSchemaColumns)
[/vba],например

Автор - krosav4ig
Дата добавления - 20.01.2019 в 04:19
Raid Дата: Воскресенье, 20.01.2019, 10:45 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Список уникальных сможете создать? С этим намного проще.


В том то и дело, что общего списка нет... Формируются около 10 таблиц изначально, и для дальнейшего удобства их нужно привести к единому виду


Сообщение отредактировал Raid - Воскресенье, 20.01.2019, 11:06
 
Ответить
Сообщение
Список уникальных сможете создать? С этим намного проще.


В том то и дело, что общего списка нет... Формируются около 10 таблиц изначально, и для дальнейшего удобства их нужно привести к единому виду

Автор - Raid
Дата добавления - 20.01.2019 в 10:45
krosav4ig Дата: Воскресенье, 20.01.2019, 23:07 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 2033
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
[vba]
Код
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
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщение[vba]
Код
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
[/vba]

Автор - krosav4ig
Дата добавления - 20.01.2019 в 23:07
Raid Дата: Вторник, 22.01.2019, 19:30 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Уважаемый krosav4ig, это по моему примеру? Я не очень продвинут в VBA, не могу понять, что этот код делает...
 
Ответить
СообщениеУважаемый krosav4ig, это по моему примеру? Я не очень продвинут в VBA, не могу понять, что этот код делает...

Автор - Raid
Дата добавления - 22.01.2019 в 19:30
Raid Дата: Пятница, 25.01.2019, 14:34 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Уважаемые знатоки, неужели нет решения этой задачи?
 
Ответить
СообщениеУважаемые знатоки, неужели нет решения этой задачи?

Автор - Raid
Дата добавления - 25.01.2019 в 14:34
krosav4ig Дата: Суббота, 26.01.2019, 18:12 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 2033
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
это по моему примеру?
Да, по вашему.
Прочитав фразу
В каждой книге таблица с столбцами подписаными по первой строке.
я понял, что у вас несколько файлов с листами, именование столбцов на которых нужно привести к общему порядку. И написал макрос, который это делает, тока часть кода забыл выложить. Добавил в ваш файл макрос, добавил в него комментарии.
[vba]
Код
'---------------------------------------------------------------------------------------
' Модуль    : 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
[/vba]

[vba]
Код
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
[/vba]
К сообщению приложен файл: 9497543.xlsm(31.0 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Суббота, 26.01.2019, 18:14
 
Ответить
Сообщение
это по моему примеру?
Да, по вашему.
Прочитав фразу
В каждой книге таблица с столбцами подписаными по первой строке.
я понял, что у вас несколько файлов с листами, именование столбцов на которых нужно привести к общему порядку. И написал макрос, который это делает, тока часть кода забыл выложить. Добавил в ваш файл макрос, добавил в него комментарии.
[vba]
Код
'---------------------------------------------------------------------------------------
' Модуль    : 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
[/vba]

[vba]
Код
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
[/vba]

Автор - krosav4ig
Дата добавления - 26.01.2019 в 18:12
Raid Дата: Суббота, 26.01.2019, 22:49 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Ой. Возможно я не так сформулировал
Файл один.
В нем несколько листов.
Часть листов нужно привести к единому виду (по первой ячейке каждого столбца) - т.е. в листах, где нет значения добавить его
Результат - листы содержат все названия столбцов одинаковы (т.е. в листе, где не было данного столбца с названием первой ячейки происходит вставка его).

В моем примере все эти листы должны в результате выглядеть так: http://prntscr.com/mckry5 (фиолетовым выделено

Так как это должен быть кусок другого макроса я намеренно не указывал какую часть листов нужно привести к единому виду (думал сделать потом по образу и подобию кем то написанного макроса...).

Перечитал еще раз свой первый пост - действительно, условия задачи сформированы очень плохо, простите...
 
Ответить
СообщениеОй. Возможно я не так сформулировал
Файл один.
В нем несколько листов.
Часть листов нужно привести к единому виду (по первой ячейке каждого столбца) - т.е. в листах, где нет значения добавить его
Результат - листы содержат все названия столбцов одинаковы (т.е. в листе, где не было данного столбца с названием первой ячейки происходит вставка его).

В моем примере все эти листы должны в результате выглядеть так: http://prntscr.com/mckry5 (фиолетовым выделено

Так как это должен быть кусок другого макроса я намеренно не указывал какую часть листов нужно привести к единому виду (думал сделать потом по образу и подобию кем то написанного макроса...).

Перечитал еще раз свой первый пост - действительно, условия задачи сформированы очень плохо, простите...

Автор - Raid
Дата добавления - 26.01.2019 в 22:49
krosav4ig Дата: Воскресенье, 27.01.2019, 00:29 | Сообщение № 10
Группа: Друзья
Ранг: Старожил
Сообщений: 2033
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Файл один.

тогда так [vba]
Код
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
[/vba]
К сообщению приложен файл: 7535897.xlsm(23.8 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
Сообщение
Файл один.

тогда так [vba]
Код
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
[/vba]

Автор - krosav4ig
Дата добавления - 27.01.2019 в 00:29
Raid Дата: Вторник, 29.01.2019, 18:09 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 26
Репутация: 0 ±
Замечаний: 0% ±

Excel 365
Прошу прощения, что через некоторое время отвечаю - проблемы с доступом к интернету.
При запуске вылетает ошибка - http://prntscr.com/mdstm4
ругается на Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов
 
Ответить
СообщениеПрошу прощения, что через некоторое время отвечаю - проблемы с доступом к интернету.
При запуске вылетает ошибка - http://prntscr.com/mdstm4
ругается на Set AL = CreateObject("system.collections.arraylist") 'объект ArrayList, в него будем собирать заголовки столбцов

Автор - Raid
Дата добавления - 29.01.2019 в 18:09
RAN Дата: Вторник, 29.01.2019, 19:36 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 5000
Репутация: 994 ±
Замечаний: 0% ±

2010
Сие работает только в Ofis 32. А у вас, вероятно, 64.


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеСие работает только в Ofis 32. А у вас, вероятно, 64.

Автор - RAN
Дата добавления - 29.01.2019 в 19:36
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Приведение столбцов в таблицах к одному виду (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!