Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.81/48: Рейтинг темы: голосов - 48, средняя оценка - 4.81
0 / 0 / 0
Регистрация: 18.01.2013
Сообщений: 11
1

VBA EXCEL: Собрать кучу файлов в один

23.01.2013, 17:49. Показов 8670. Ответов 4
Метки нет (Все метки)

В папке находится куча xls файлов. У всех у них одинаковая структура. Но она может меняться периодически. Необходимо все файлы собрать в один.
Первый файл из которого будут браться данные копируется полностью, включая заголовки. А у последующих файлов данные беруться без заголовков
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
23.01.2013, 17:49
Ответы с готовыми решениями:

Собрать из большой кучи файлов разной структуры некоторые данные в один - VBA
Добрый день, с VBA не знакома, прошу подсказать - по форуму поиском смотрю - есть темы -...

Собрать кучу файлов в один файл Excel
Добрый день! И снова смиренно прошу советов гуру. Исходные данные: около 600 файлов формата csv(3...

Требуется собрать кучу object в один контейнер и искать их по object_name
Пусть дана структура вида: struct object { object(const...

Разбить один m-файл на кучу маленьких m-файлов
Здравствуйте. Я не новичок в Matlab. Однако просто раньше такого не требовалось. У меня ну просто...

4
5349 / 1413 / 332
Регистрация: 23.12.2010
Сообщений: 2,081
Записей в блоге: 1
24.01.2013, 13:49 2
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Sub Собрать_данные_из_xls_файлов()
    ' Макрос создает книгу и последовательно вставляет на одноименные листы
    ' данные из всех xls файлов заданной директории начиная со строки FRow.
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const Sborka$ = "Сборка.xls"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    MyPath = "C:\temp4\"
    ' MyPath = CurDir & "\"
    MyFileName = Dir(MyPath & "*.xls*")
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> Sborka Then
            MyFulName = MyPath & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
                ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop
End Sub
1
0 / 0 / 0
Регистрация: 18.01.2013
Сообщений: 11
24.01.2013, 18:38  [ТС] 3
KoGG, спасибо!
То что нужно!

Добавлено через 12 минут
Не много изменил. Добавил возможность выбора папки, в которой хранятся файлы. Может кому и пригодится
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Sub Собрать_данные_из_xls_файлов()
    ' Макрос создает книгу и последовательно вставляет на одноименные листы
    ' данные из всех xls файлов заданной директории начиная со строки FRow.
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const Sborka$ = "Сборка.xls"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    
    ' Выбор папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
      
       
    
       
    'MyPath = "C:\inbox\Тест Макроса\Тест\"
    ' MyPath = CurDir & "\"
    MyFileName = Dir(MyPath & "*.xls*")
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> Sborka Then
            MyFulName = MyPath & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
                ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop
End Sub
0
0 / 0 / 0
Регистрация: 27.01.2017
Сообщений: 1
12.05.2017, 14:02 4
Добрый день! Почти идеально подошел вышеуказанный макрос, только для моей задачи необходимо чтобы в каждой строчке еще был указан исходный файл, т.е. чтобы было видно что эти 5 наименований пришли из файла А , а другие 7 из файла И и т.д. Не подскажете что тут дописать/изменить?
0
5349 / 1413 / 332
Регистрация: 23.12.2010
Сообщений: 2,081
Записей в блоге: 1
13.05.2017, 17:11 5
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Sub Собрать_данные_из_xls_файлов()
    ' Макрос создает книгу и последовательно вставляет на одноименные листы
    ' данные из всех xls файлов заданной директории начиная со строки FRow.
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const Sborka$ = "Сборка.xls"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    
    ' Выбор папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
      
       
    
       
    'MyPath = "C:\inbox\Тест Макроса\Тест\"
    ' MyPath = CurDir & "\"
    MyFileName = Dir(MyPath & "*.xls*")
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> Sborka Then
            MyFulName = MyPath & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
                ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                            With Sh_Cel
                                    Range(.Cells(LRow_Cel , 2+LCol-FCol), .Cells(LRow_Cel+LRow-FRow,  2+LCol-FCol))= MyFulName
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop
End Sub
1
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
13.05.2017, 17:11

Заказываю контрольные, курсовые, дипломные работы и диссертации здесь.

Собрать данные VBA Excel
Добрый день Уважаемые форумчане! Прошу Вас помочь мне с кодом. У меня есть данные в таком виде:...

Собрать данные из нескольких файлов в один
Добрый день! Уважаемые хакеры нужна ваша помощь. Проблема: есть папка в которой...

Как собрать данные из нескольких файлов в один
Доброго времяни суток! Помогите плиз Ламеру, сломал голову. Есть задача собрать данные (2 столбца)...

Собрать данные из нескольких листов Excel на один лист
Добрый день! Подскажите как решить следующую задачку: Нужно собрать данные с листов Эксель,...

Собрать все xml файлы в один и открыть в excel
Добрый день! Подскажите , Собрать все xml файлы в один , и можно ли этот файл открыть в excel в...

Макросы на копирование данных из нескольких файлов excel в один файл excel
Здравствуйте! Помогите сделать два макроса в excel, которые будут копировать данные из множества...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
5
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.