Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Объединение несколько столбцов в один друг под другом, Сбор данных в один столбец
 
#1
25.03.2022 13:36:22
Добрый день, Уважаемые знатоки.

Есть несколько десятков файлов с одинаковыми данными внутри. (пример во вложении)
Каким образом можно объединить все столбцы в один друг под другом без шапки, только значения в ячейках (KAA19514)?
Столбцов в файлах может быть разное количество



Заранее благодарю за помощь.
 
 
 
#2
25.03.2022 13:53:37
Код
Option Explicit

Sub СобратьФайлы()
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    Dim rOut As Range
    Set rOut = wb.Sheets(1).Cells(1, 1)
    Dim vFile As Variant
    For Each vFile In arrFiles
        JobFile vFile, rOut
    Next
    
    Application.Calculation = Application_Calculation
    wb.Saved = True
End Sub

Sub JobFile(ByVal sFile As String, rOut As Range)
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFile, False, True)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        JobSheet sh, rOut
    Next
    wb.Close False
End Sub

Sub JobSheet(sh As Worksheet, rOut As Range)
    With sh
        Dim arr As Variant
        arr = .UsedRange.Offset(2).Resize(.UsedRange.Rows.Count - 2)
        rOut.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
        Set rOut = rOut.Cells(UBound(arr, 1) + 1, 1)
    End With
End Sub

Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
        ShowFileDialog = arr
    End With
End Function
 
 
 
#3
25.03.2022 13:58:06
,

Добрый день. Спасибо большое, макрос собирает на новый лист столбцы с данными? А собрать их в один длинный столбец возможно?
 
 
 
#4
25.03.2022 14:02:51
Уберите пустые столбцы и применните Power Query.
Код
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"№ паллета ", type any}, {"1117", type text}, {"1118", type text}, {"1119", type text}, {"1120", type text}, {"1121", type text}, {"1122", type text}, {"1123", type text}, {"1124", type text}, {"1125", type text}, {"1126", type text}, {"1127", type text}, {"1128", type text}, {"1129", type text}, {"1130", type text}, {"1131", type text}, {"1132", type text}, {"1133", type text}, {"1135", type text}, {"1136", type text}, {"1137", type text}, {"1138", type text}, {"1139", type text}, {"1140", type text}, {"1141", type text}, {"1142", type text}}),
    #"Removed Top Rows" = Table.Skip(#"Changed Type",1),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Removed Top Rows", {"№ паллета "}, "Attribute", "Value"),
    #"Sorted Rows" = Table.Sort(#"Unpivoted Other Columns",{{"Attribute", Order.Ascending}}),
    #"Removed Columns" = Table.RemoveColumns(#"Sorted Rows",{"№ паллета "}),
    #"Renamed Columns" = Table.RenameColumns(#"Removed Columns",{{"Attribute", "№ паллета"}, {"Value", "ШК Короба"}})
in
    #"Renamed Columns"
Изменено: jakim - 25.03.2022 14:16:22
 
 
 
#5
25.03.2022 14:19:31
,Подскажите, пожалуйста, я меняю количество столбцов например убираю 10 или добавляю запрос ошибку выдает. не хватает столбца №***
 
 
 
#6
25.03.2022 14:19:37
Код
Option Explicit
'v2
Sub СобратьФайлы()
    Dim arrFiles As Variant
    arrFiles = ShowFileDialog()
    If IsEmpty(arrFiles) Then Exit Sub
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
     
    Dim wb As Workbook
    Set wb = Workbooks.Add(1)
    Dim rOut As Range
    Set rOut = wb.Sheets(1).Cells(1, 1)
    Dim vFile As Variant
    For Each vFile In arrFiles
        JobFile vFile, rOut
    Next
     
    Application.Calculation = Application_Calculation
    wb.Saved = True
End Sub
 
Sub JobFile(ByVal sFile As String, rOut As Range)
    Dim wb As Workbook
    Set wb = Workbooks.Open(sFile, False, True)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        JobSheet sh, rOut
    Next
    wb.Close False
End Sub
 
Sub JobSheet(sh As Worksheet, rOut As Range)
    With sh
        Dim arr As Variant
        Dim arrHead As Variant
        arrHead = .Rows(3)
        Dim xx As Integer
        Dim yy As Long
        For xx = 2 To UBound(arrHead, 2)
            If arrHead(1, xx) <> "" Then
                yy = .Cells(.Rows.Count, xx).End(xlUp).Row
                If yy = 3 Then
                    ReDim arr(1 To 1, 1 To 1)
                    arr(1, 1) = .Cells(yy, xx).Value
                ElseIf yy > 3 Then
                    arr = .Range(.Cells(3, xx), .Cells(yy, xx))
                End If
                If Not IsEmpty(arr) Then
                    rOut.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
                    Set rOut = rOut.Cells(UBound(arr, 1) + 1, 1)
                End If
                Erase arr
            End If
        Next
    End With
End Sub
 
Function ShowFileDialog() As Variant
    Dim oFD As FileDialog
    Dim lf As Long
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'так же можно без oFD
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Title = "Выбрать файлы" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Excel files", "*.xls*;*.xla*", 1 'устанавливаем возможность выбора только файлов Excel
        '.Filters.Add "Text files", "*.txt", 2 'добавляем возможность выбора текстовых файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию - Text files(Текстовые файлы)
        .InitialFileName = ThisWorkbook.Path & "\"
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)
        If oFD.Show = 0 Then Exit Function 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        Dim arr As Variant
        ReDim arr(1 To .SelectedItems.Count)
        For lf = 1 To .SelectedItems.Count
            arr(lf) = .SelectedItems(lf) 'считываем полный путь к файлу
        Next
        ShowFileDialog = arr
    End With
End Function
 
 
 
#7
25.03.2022 14:22:16
,
,

Спасибо Вам огромное за помощь. Вы очень помогли
 
 
 
Страницы: 1
Наверх