ReSQL.ru
     
powered by simpleCommunicator - 2.0.58     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос в Excel для создания единого файла из нескольких
5 сообщений из 5, страница 1 из 1
Макрос в Excel для создания единого файла из нескольких
    #37169864
Rammyar
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Rammyar
Гость
Добрый день!
У меня такая ситуация: необходимо написать макрос, который бы копировал содержимое из разных файлов в один общий.
Более конкретно: в папке хранятся файлы excel с графиками отпусков от разных отделов (buh, prod и др.). Их содержимое нужно скопировать в единую таблицу в файле itog. Шапка во всех файлах одна и та же, количество копируемых строк может быть разным (нужно копировать до последней заполненной строки включительно в столбце F).

В качестве образца использую макросы из этой темы: http://www.sql.ru/forum/actualthread.aspx?tid=620731

Есть вот такой вариант:
Код: plaintext
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.
Sub CollectInfo()
Dim BazaWb As Workbook 'книга с макросом (общий файл)
Dim BazaSht As Worksheet 'лист в общем файле куда будем копировать
Dim iTempFileName As String 'имя поочерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле
Dim iNumFiles As Long 'количество открываемых файлов
Dim TempSht As Worksheet 'каждый лист в открываемых файлах

    If MsgBox("Скопировать информацию из всех файлов в текущей папке в данный файл?", vbOKCancel + vbQuestion, _
        "Копирование инфо") = vbCancel Then Exit Sub
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .ShowWindowsInTaskbar = False
        Set BazaWb = ThisWorkbook
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                Set BazaSht = BazaWb.Sheets.Add
                On Error Resume Next
                BazaWb.Sheets(Left(iTempFileName, Len(iTempFileName) -  4 )).Delete
                On Error GoTo  0 
                BazaSht.Name = Left(iTempFileName, Len(iTempFileName) -  4 )
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                    iNumFiles = iNumFiles +  1 
                    For Each TempSht In .Worksheets
                        iLastRowBaza = BazaSht.Cells(Rows.Count,  5 ).End(xlUp).Row +  3 
                        With TempSht
                            iLastRowTempWb = .Cells(Rows.Count,  5 ).End(xlUp).Row
                            'копируем диапазон со столбца А до АС включительно
                            .Range(.Cells( 1 ,  1 ), .Cells(iLastRowTempWb, "AC")).Copy Destination:=BazaSht.Cells(iLastRowBaza,  1 )
                        End With
                    Next
                    .Close saveChanges:=False
                    BazaSht.Rows("1:3").Delete
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .ShowWindowsInTaskbar = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Информация скопирована из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub


Он копирует все правильно, но каждый файл - на отдельный лист. Как сделать так, чтобы копировал все на один, причем шапку - только один раз, сверху?

Файл-пример прилагаю. Всем большое спасибо за помощь!
...
Рейтинг: 0 / 0
17.03.2011, 13:04
| Ответить | Цитировать | Написать  
Макрос в Excel для создания единого файла из нескольких
    #37169940
Rammyar
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Rammyar
Гость
И сам файл
...
Рейтинг: 0 / 0
17.03.2011, 13:31
| Ответить | Цитировать | Написать  
Макрос в Excel для создания единого файла из нескольких
    #37170982
sergeyvg
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
sergeyvg
Гость
попробуйте так
1. строчку
Код: plaintext
Set BazaSht = BazaWb.Sheets.Add
заменить на
Код: plaintext
if iNumFiles =  0  then Set BazaSht = BazaWb.Sheets.Add
2. убрать строчку BazaSht.Rows("1:3").Delete
3. и аккуратнее с with (может стоит от них отказаться и прописать все явно), например здесь
Код: plaintext
iLastRowBaza = BazaSht.Cells(Rows.Count,  5 ).End(xlUp).Row +  3
надо бы так
Код: plaintext
iLastRowBaza = BazaSht.Cells(BazaSht.Rows.Count,  5 ).End(xlUp).Row +  3
...
Рейтинг: 0 / 0
17.03.2011, 20:03
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Макрос в Excel для создания единого файла из нескольких
    #38294562
Samvelik
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Samvelik
Гость
Друзья, незначительно переделал Вашь код под свои потребности, но к сожалению знаниями VBS не обладаю и поэтому необходима Ваша помощь.
А сделать нужно следующее
1. Обновление (перенос данных) должно происходить в одной закладке, автоматически при открытии файла
2. Форматироввание переносимого файла должно сохранятся (или задано настройками, интересует ширина столбцов)
3. Копироваться из файлов должно все, кроме строки № 1

Заранее спасибо за помощь !
Внизу переделанный код, в соответствии с рекомендациями sergeyvg и моей небольшой доработкой

Код: vbnet
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 &#209;&#225;&#238;&#240;_&#232;&#237;&#244;&#238;_&#232;&#231;_&#226;&#241;&#229;&#245;_&#244;&#224;&#233;&#235;&#238;&#226;()
'&#241;&#238;&#225;&#232;&#240;&#224;&#229;&#236; &#232;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#254; &#241;&#238; &#226;&#241;&#229;&#245; &#244;&#224;&#233;&#235;&#238;&#226; &#241;&#238; &#226;&#241;&#229;&#245; &#235;&#232;&#241;&#242;&#238;&#226;
'&#226; &#242;&#229;&#234;&#243;&#249;&#243;&#254; &#234;&#237;&#232;&#227;&#243;
Dim BazaWb As Workbook '&#234;&#237;&#232;&#227;&#224; &#241; &#236;&#224;&#234;&#240;&#238;&#241;&#238;&#236; (&#238;&#225;&#249;&#232;&#233; &#244;&#224;&#233;&#235;)
Dim BazaSht As Worksheet '&#235;&#232;&#241;&#242; &#226; &#238;&#225;&#249;&#229;&#236; &#244;&#224;&#233;&#235;&#229; &#234;&#243;&#228;&#224; &#225;&#243;&#228;&#229;&#236; &#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#242;&#252;
Dim iTempFileName As String '&#232;&#236;&#255; &#239;&#238;&#238;&#247;&#229;&#240;&#184;&#228;&#237;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#238;&#227;&#238; &#244;&#224;&#233;&#235;&#224;
Dim iPath As String '&#239;&#243;&#242;&#252; &#234; &#239;&#224;&#239;&#234;&#229;, &#227;&#228;&#229; &#235;&#229;&#230;&#224;&#242; &#226;&#241;&#229; &#244;&#224;&#233;&#235;&#251;
Dim iLastRowBaza As Long '&#239;&#238;&#241;&#235;&#229;&#228;&#237;&#255;&#255; &#231;&#224;&#239;&#238;&#235;&#237;&#229;&#237;&#237;&#224;&#255; &#241;&#242;&#240;&#238;&#234;&#224; &#226; &#238;&#225;&#249;&#229;&#236; &#244;&#224;&#233;&#235;&#229;
Dim iLastRowTempWb As Long '&#239;&#238;&#241;&#235;&#229;&#228;&#237;&#255;&#255; &#231;&#224;&#239;&#238;&#235;&#237;&#229;&#237;&#237;&#224;&#255; &#241;&#242;&#240;&#238;&#234;&#224; &#226; &#239;&#238;-&#238;&#247;&#229;&#240;&#184;&#228;&#237;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#238;&#236; &#244;&#224;&#233;&#235;&#229;
Dim iNumFiles As Long '&#234;&#238;&#235;&#232;&#247;&#229;&#241;&#242;&#226;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#251;&#245; &#244;&#224;&#233;&#235;&#238;&#226;
Dim TempSht As Worksheet '&#234;&#224;&#230;&#228;&#251;&#233; &#235;&#232;&#241;&#242; &#226; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#251;&#245; &#244;&#224;&#233;&#235;&#224;&#245;

    If MsgBox("&#209;&#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#242;&#252; &#232;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#254; &#232;&#231; &#226;&#241;&#229;&#245; &#244;&#224;&#233;&#235;&#238;&#226; &#226; &#242;&#229;&#234;&#243;&#249;&#229;&#233; &#239;&#224;&#239;&#234;&#229; &#226; &#228;&#224;&#237;&#237;&#251;&#233; &#244;&#224;&#233;&#235;?", vbOKCancel + vbQuestion, _
        "&#202;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#237;&#232;&#229; &#232;&#237;&#244;&#238;") = vbCancel Then Exit Sub
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .ShowWindowsInTaskbar = False
        Set BazaWb = ThisWorkbook
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                If iNumFiles = 0 Then Set BazaSht = BazaWb.Sheets.Add
                On Error Resume Next
                BazaWb.Sheets(Left(iTempFileName, Len(iTempFileName) - 4)).Delete
                On Error GoTo 0
                'BazaSht.Name = Left(iTempFileName, Len(iTempFileName) - 4)
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                    iNumFiles = iNumFiles + 1
                    For Each TempSht In .Worksheets
                    iLastRowBaza = BazaSht.Cells(BazaSht.Rows.Count, 5).End(xlUp).Row + 1
                        With TempSht
                            iLastRowTempWb = .Cells(Rows.Count, 5).End(xlUp).Row
                            '&#234;&#238;&#239;&#232;&#240;&#243;&#229;&#236; &#228;&#232;&#224;&#239;&#224;&#231;&#238;&#237; &#241;&#238; &#241;&#242;&#238;&#235;&#225;&#246;&#224; &#192; &#228;&#238; &#192;&#209; &#226;&#234;&#235;&#254;&#247;&#232;&#242;&#229;&#235;&#252;&#237;&#238;
                            .Range(.Cells(1, 1), .Cells(iLastRowTempWb, "AC")).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                        End With
                    Next
                    .Close saveChanges:=False
                    'BazaSht.Rows("1:3").Delete
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .ShowWindowsInTaskbar = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "&#200;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#255; &#241;&#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#237;&#224; &#232;&#231; " & iNumFiles & " &#244;&#224;&#233;&#235;&#238;&#226;!", vbInformation, "&#202;&#238;&#237;&#229;&#246;"
End Sub

Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With BazaWb.Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
...
Рейтинг: 0 / 0
11.06.2013, 18:55
| Ответить | Цитировать | Написать  
Макрос в Excel для создания единого файла из нескольких
    #38294566
Samvelik
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Samvelik
Гость
Друзья, незначительно переделал Вашь код под свои потребности, но к сожалению знаниями VBS не обладаю и поэтому необходима Ваша помощь.
А сделать нужно следующее
1. Обновление (перенос данных) должно происходить в одной закладке, автоматически при открытии файла
2. Форматироввание переносимого файла должно сохранятся (или задано настройками, интересует ширина столбцов)
3. Копироваться из файлов должно все, кроме строки № 1

Заранее спасибо за помощь !
Внизу переделанный код, в соответствии с рекомендациями sergeyvg и моей небольшой доработкой
Код: vbnet
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.
Sub &#209;&#225;&#238;&#240;_&#232;&#237;&#244;&#238;_&#232;&#231;_&#226;&#241;&#229;&#245;_&#244;&#224;&#233;&#235;&#238;&#226;()
'&#241;&#238;&#225;&#232;&#240;&#224;&#229;&#236; &#232;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#254; &#241;&#238; &#226;&#241;&#229;&#245; &#244;&#224;&#233;&#235;&#238;&#226; &#241;&#238; &#226;&#241;&#229;&#245; &#235;&#232;&#241;&#242;&#238;&#226;
'&#226; &#242;&#229;&#234;&#243;&#249;&#243;&#254; &#234;&#237;&#232;&#227;&#243;
Dim BazaWb As Workbook '&#234;&#237;&#232;&#227;&#224; &#241; &#236;&#224;&#234;&#240;&#238;&#241;&#238;&#236; (&#238;&#225;&#249;&#232;&#233; &#244;&#224;&#233;&#235;)
Dim BazaSht As Worksheet '&#235;&#232;&#241;&#242; &#226; &#238;&#225;&#249;&#229;&#236; &#244;&#224;&#233;&#235;&#229; &#234;&#243;&#228;&#224; &#225;&#243;&#228;&#229;&#236; &#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#242;&#252;
Dim iTempFileName As String '&#232;&#236;&#255; &#239;&#238;&#238;&#247;&#229;&#240;&#184;&#228;&#237;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#238;&#227;&#238; &#244;&#224;&#233;&#235;&#224;
Dim iPath As String '&#239;&#243;&#242;&#252; &#234; &#239;&#224;&#239;&#234;&#229;, &#227;&#228;&#229; &#235;&#229;&#230;&#224;&#242; &#226;&#241;&#229; &#244;&#224;&#233;&#235;&#251;
Dim iLastRowBaza As Long '&#239;&#238;&#241;&#235;&#229;&#228;&#237;&#255;&#255; &#231;&#224;&#239;&#238;&#235;&#237;&#229;&#237;&#237;&#224;&#255; &#241;&#242;&#240;&#238;&#234;&#224; &#226; &#238;&#225;&#249;&#229;&#236; &#244;&#224;&#233;&#235;&#229;
Dim iLastRowTempWb As Long '&#239;&#238;&#241;&#235;&#229;&#228;&#237;&#255;&#255; &#231;&#224;&#239;&#238;&#235;&#237;&#229;&#237;&#237;&#224;&#255; &#241;&#242;&#240;&#238;&#234;&#224; &#226; &#239;&#238;-&#238;&#247;&#229;&#240;&#184;&#228;&#237;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#238;&#236; &#244;&#224;&#233;&#235;&#229;
Dim iNumFiles As Long '&#234;&#238;&#235;&#232;&#247;&#229;&#241;&#242;&#226;&#238; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#251;&#245; &#244;&#224;&#233;&#235;&#238;&#226;
Dim TempSht As Worksheet '&#234;&#224;&#230;&#228;&#251;&#233; &#235;&#232;&#241;&#242; &#226; &#238;&#242;&#234;&#240;&#251;&#226;&#224;&#229;&#236;&#251;&#245; &#244;&#224;&#233;&#235;&#224;&#245;

    If MsgBox("&#209;&#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#242;&#252; &#232;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#254; &#232;&#231; &#226;&#241;&#229;&#245; &#244;&#224;&#233;&#235;&#238;&#226; &#226; &#242;&#229;&#234;&#243;&#249;&#229;&#233; &#239;&#224;&#239;&#234;&#229; &#226; &#228;&#224;&#237;&#237;&#251;&#233; &#244;&#224;&#233;&#235;?", vbOKCancel + vbQuestion, _
        "&#202;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#237;&#232;&#229; &#232;&#237;&#244;&#238;") = vbCancel Then Exit Sub
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        .ShowWindowsInTaskbar = False
        Set BazaWb = ThisWorkbook
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xls")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                If iNumFiles = 0 Then Set BazaSht = BazaWb.Sheets.Add
                On Error Resume Next
                BazaWb.Sheets(Left(iTempFileName, Len(iTempFileName) - 4)).Delete
                On Error GoTo 0
                'BazaSht.Name = Left(iTempFileName, Len(iTempFileName) - 4)
                'BazaSht.Name = "&#209;&#226;&#238;&#228;&#237;&#224;&#255; &#204;&#196;"
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                    iNumFiles = iNumFiles + 1
                    For Each TempSht In .Worksheets
                    iLastRowBaza = BazaSht.Cells(BazaSht.Rows.Count, 5).End(xlUp).Row + 1
                        With TempSht
                            iLastRowTempWb = .Cells(Rows.Count, 5).End(xlUp).Row
                            '&#234;&#238;&#239;&#232;&#240;&#243;&#229;&#236; &#228;&#232;&#224;&#239;&#224;&#231;&#238;&#237; &#241;&#238; &#241;&#242;&#238;&#235;&#225;&#246;&#224; &#192; &#228;&#238; &#192;&#209; &#226;&#234;&#235;&#254;&#247;&#232;&#242;&#229;&#235;&#252;&#237;&#238;
                            .Range(.Cells(1, 1), .Cells(iLastRowTempWb, "AC")).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                        End With
                    Next
                    .Close saveChanges:=False
                    'BazaSht.Rows("1:3").Delete
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .ShowWindowsInTaskbar = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "&#200;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#255; &#241;&#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#237;&#224; &#232;&#231; " & iNumFiles & " &#244;&#224;&#233;&#235;&#238;&#226;!", vbInformation, "&#202;&#238;&#237;&#229;&#246;"
End Sub

Function SheetExist(iName As String) As Boolean
    On Error Resume Next
    With BazaWb.Worksheets(iName): End With
    SheetExist = (Err = 0)
End Function
...
Рейтинг: 0 / 0
11.06.2013, 18:58
| Ответить | Цитировать | Написать  
5 сообщений из 5, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос в Excel для создания единого файла из нескольких
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=38294566&tid=2174739]:
 0ms
get settings:
 11ms
get forum list:
 13ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 29ms
get topic data:
 11ms
get forum data:
 2ms
get page messages:
 34ms
get tp. blocked users:
 2ms
others: 12ms
total:  120ms
созд. / загр.: 120ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]