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

Вход

Регистрация

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

 

= Мир MS Excel/Перебор файлов в папках и в подпапках - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перебор файлов в папках и в подпапках (Макросы/Sub)
Перебор файлов в папках и в подпапках
Sancho Дата: Среда, 17.08.2016, 09:53 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 0% ±

2007, 2010, 2013
Всем привет. Есть макрос, который производит сбор данных с файлов которые лежат в этой же папке. Нужно переделать код, что бы перебирал все файлы в общей папке, где лежит файл с этим макросом, и в подпапках. Количество этих подпапок может быть разное.
[vba]
Код
Sub CollectAllClients()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'сводный лист
Dim iTempFileName As String 'имя по-очерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iNumFiles As Long 'количество открываемых файлов

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        Set BazaWb = ThisWorkbook
        Set BazaSht = BazaWb.Sheets("Лист1")
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xlsm")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                     iNumFiles = iNumFiles + 1
                     With .Worksheets("Лист1")
                        'последняя строка в открытом файле
                        If .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).MergeCells Then
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                        Else
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row
                        End If
                        'последняя строка в базе
                        If BazaSht.Cells(Rows.Count, 1).End(xlUp).MergeCells Then
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 2
                        Else
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        End If
                          .Range(.Cells(3, 1), .Cells(iLastRowTempWb, 15)).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                     End With
                     .Close saveChanges:=False
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Информация собрана из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub
[/vba]


Сообщение отредактировал Sancho - Среда, 17.08.2016, 09:56
 
Ответить
СообщениеВсем привет. Есть макрос, который производит сбор данных с файлов которые лежат в этой же папке. Нужно переделать код, что бы перебирал все файлы в общей папке, где лежит файл с этим макросом, и в подпапках. Количество этих подпапок может быть разное.
[vba]
Код
Sub CollectAllClients()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'сводный лист
Dim iTempFileName As String 'имя по-очерёдно открываемого файла
Dim iPath As String 'путь к папке, где лежат все файлы
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iNumFiles As Long 'количество открываемых файлов

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlManual
        Set BazaWb = ThisWorkbook
        Set BazaSht = BazaWb.Sheets("Лист1")
        iPath = BazaWb.Path & "\"
        iTempFileName = Dir(iPath & "*.xlsm")
        Do While iTempFileName <> ""
            If iTempFileName <> BazaWb.Name Then
                With .Workbooks.Open _
                     (Filename:=iPath & iTempFileName, UpdateLinks:=False, ReadOnly:=True)
                     iNumFiles = iNumFiles + 1
                     With .Worksheets("Лист1")
                        'последняя строка в открытом файле
                        If .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).MergeCells Then
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                        Else
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row
                        End If
                        'последняя строка в базе
                        If BazaSht.Cells(Rows.Count, 1).End(xlUp).MergeCells Then
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 2
                        Else
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        End If
                          .Range(.Cells(3, 1), .Cells(iLastRowTempWb, 15)).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                     End With
                     .Close saveChanges:=False
                End With
            End If
            iTempFileName = Dir
        Loop
        .Calculation = xlAutomatic
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    MsgBox "Информация собрана из " & iNumFiles & " файлов!", vbInformation, "Конец"
End Sub
[/vba]

Автор - Sancho
Дата добавления - 17.08.2016 в 09:53
sboy Дата: Среда, 17.08.2016, 10:15 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
Добрый день.
Вот тут пример
 
Ответить
СообщениеДобрый день.
Вот тут пример

Автор - sboy
Дата добавления - 17.08.2016 в 10:15
Sancho Дата: Среда, 17.08.2016, 10:49 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 0% ±

2007, 2010, 2013
sboy, Добрый. Все там конечно замечательно, но разобраться без комментариев, что нужно оттуда подчеркнуть, черт ногу сломит)
 
Ответить
Сообщениеsboy, Добрый. Все там конечно замечательно, но разобраться без комментариев, что нужно оттуда подчеркнуть, черт ногу сломит)

Автор - Sancho
Дата добавления - 17.08.2016 в 10:49
sboy Дата: Среда, 17.08.2016, 11:21 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
Не проверял, но приблизительно так (совместил Ваш макрос с решением)
[vba]
Код
Option Explicit

Dim objFSO As Object, objFolder As Object, objFile As Object

Sub Get_All_File_from_SubFolders()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'сводный лист
    Dim sFolder As String
    'With Application.FileDialog(msoFileDialogFolderPicker)
        'If .Show = False Then Exit Sub
        'sFolder = .SelectedItems(1)
    'End With
    Set BazaWb = ThisWorkbook
    Set BazaSht = BazaWb.Sheets("Лист1")
    sFolder = BazaWb.Path
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder, BazaSht
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath, BazaSht)
Dim BazaSht As Worksheet
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iNumFiles As Long 'количество открываемых файлов
    Dim sPathSeparator As String, sObjName As String
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            
           With Application.Workbooks.Open(Filename:=sPath & objFile.Name, UpdateLinks:=False, ReadOnly:=True)
                iNumFiles = iNumFiles + 1
                    With .Worksheets("Лист1")
                        'последняя строка в открытом файле
                        If .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).MergeCells Then
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                        Else
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row
                        End If
                        'последняя строка в базе
                        If BazaSht.Cells(Rows.Count, 1).End(xlUp).MergeCells Then
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 2
                        Else
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        End If
                        .Range(.Cells(3, 1), .Cells(iLastRowTempWb, 15)).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                    End With
            'ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
            'ActiveWorkbook.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub
[/vba]
 
Ответить
СообщениеНе проверял, но приблизительно так (совместил Ваш макрос с решением)
[vba]
Код
Option Explicit

Dim objFSO As Object, objFolder As Object, objFile As Object

Sub Get_All_File_from_SubFolders()
Dim BazaWb As Workbook 'текущая книга (общий файл)
Dim BazaSht As Worksheet 'сводный лист
    Dim sFolder As String
    'With Application.FileDialog(msoFileDialogFolderPicker)
        'If .Show = False Then Exit Sub
        'sFolder = .SelectedItems(1)
    'End With
    Set BazaWb = ThisWorkbook
    Set BazaSht = BazaWb.Sheets("Лист1")
    sFolder = BazaWb.Path
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder, BazaSht
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
End Sub
Private Sub GetSubFolders(sPath, BazaSht)
Dim BazaSht As Worksheet
Dim iLastRowBaza As Long 'последняя заполненная строка в общем файле в столбце A
Dim iLastRowTempWb As Long 'последняя заполненная строка в по-очерёдно открываемом файле в столбце A
Dim iNumFiles As Long 'количество открываемых файлов
    Dim sPathSeparator As String, sObjName As String
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.Name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            
           With Application.Workbooks.Open(Filename:=sPath & objFile.Name, UpdateLinks:=False, ReadOnly:=True)
                iNumFiles = iNumFiles + 1
                    With .Worksheets("Лист1")
                        'последняя строка в открытом файле
                        If .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1).MergeCells Then
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                        Else
                            iLastRowTempWb = .Cells(Rows.Count, 2).End(xlUp).Row
                        End If
                        'последняя строка в базе
                        If BazaSht.Cells(Rows.Count, 1).End(xlUp).MergeCells Then
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 2
                        Else
                            iLastRowBaza = BazaSht.Cells(Rows.Count, 2).End(xlUp).Row + 1
                        End If
                        .Range(.Cells(3, 1), .Cells(iLastRowTempWb, 15)).Copy Destination:=BazaSht.Cells(iLastRowBaza, 1)
                    End With
            'ActiveWorkbook.Sheets(1).Range("A1").Value = "www.excel-vba.ru"
            'ActiveWorkbook.Close True
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub
[/vba]

Автор - sboy
Дата добавления - 17.08.2016 в 11:21
Sancho Дата: Среда, 17.08.2016, 11:54 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 0% ±

2007, 2010, 2013
sboy, Argument not optional (Error 449)
на эту строку[vba]
Код
GetSubFolders objFolder.Path & Application.PathSeparator
[/vba]
 
Ответить
Сообщениеsboy, Argument not optional (Error 449)
на эту строку[vba]
Код
GetSubFolders objFolder.Path & Application.PathSeparator
[/vba]

Автор - Sancho
Дата добавления - 17.08.2016 в 11:54
sboy Дата: Среда, 17.08.2016, 12:08 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
[vba]
Код
GetSubFolders objFolder.Path & Application.PathSeparator, BazaSht
[/vba]
так попробуйте
 
Ответить
Сообщение[vba]
Код
GetSubFolders objFolder.Path & Application.PathSeparator, BazaSht
[/vba]
так попробуйте

Автор - sboy
Дата добавления - 17.08.2016 в 12:08
Sancho Дата: Среда, 17.08.2016, 13:56 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 0% ±

2007, 2010, 2013
sboy, спасибо, пришлось еще немного поковырять, что бы заработало. теперь не могу сообразить как заставить считать нормально счетчик файлов, что бы отобразить в сообщении сколько файлов было обработано по окончании работы макроса. Сейчас [vba]
Код
iNumFiles = iNumFiles + 1
[/vba]считает сколько файлов открыл при исполнении последнего цикла перебора файлов, т.е. в последней папке.
 
Ответить
Сообщениеsboy, спасибо, пришлось еще немного поковырять, что бы заработало. теперь не могу сообразить как заставить считать нормально счетчик файлов, что бы отобразить в сообщении сколько файлов было обработано по окончании работы макроса. Сейчас [vba]
Код
iNumFiles = iNumFiles + 1
[/vba]считает сколько файлов открыл при исполнении последнего цикла перебора файлов, т.е. в последней папке.

Автор - Sancho
Дата добавления - 17.08.2016 в 13:56
sboy Дата: Среда, 17.08.2016, 16:00 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
Sancho, тут мне трудно без испытаний макроса)
как вариант выводить сообщение с количеством файлов после обработки каждой папки, но думаю что это вам не нужно...
 
Ответить
СообщениеSancho, тут мне трудно без испытаний макроса)
как вариант выводить сообщение с количеством файлов после обработки каждой папки, но думаю что это вам не нужно...

Автор - sboy
Дата добавления - 17.08.2016 в 16:00
Manyasha Дата: Среда, 17.08.2016, 16:16 | Сообщение № 9
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
Sancho, сделайте переменную iNumFiles глобальной, чтобы она не обнулялась при каждом запуске макроса GetSubFolders.


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеSancho, сделайте переменную iNumFiles глобальной, чтобы она не обнулялась при каждом запуске макроса GetSubFolders.

Автор - Manyasha
Дата добавления - 17.08.2016 в 16:16
sboy Дата: Среда, 17.08.2016, 16:26 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

Excel 2007
сделайте переменную iNumFiles глобальной

действительно) и просто и изящно)))
 
Ответить
Сообщение
сделайте переменную iNumFiles глобальной

действительно) и просто и изящно)))

Автор - sboy
Дата добавления - 17.08.2016 в 16:26
Sancho Дата: Четверг, 18.08.2016, 12:16 | Сообщение № 11
Группа: Пользователи
Ранг: Участник
Сообщений: 88
Репутация: 0 ±
Замечаний: 0% ±

2007, 2010, 2013
Manyasha, спасибо. А я уж голову сломал, но все же выкрутился добавив еще одну, но уже глобальную переменную
[vba]
Код
iNumFiles1 = iNumFiles1+iNumFiles
[/vba]
правда пришлось методом тыка искать куда эту строку воткнуть.
добавил еще строку для обнуления переменной[vba]
Код
iNumFiles1=0
[/vba] ибо счетчик при повторном запуске продолжал считать
Спасибо, сейчас и Ваш вариант протестирую
 
Ответить
СообщениеManyasha, спасибо. А я уж голову сломал, но все же выкрутился добавив еще одну, но уже глобальную переменную
[vba]
Код
iNumFiles1 = iNumFiles1+iNumFiles
[/vba]
правда пришлось методом тыка искать куда эту строку воткнуть.
добавил еще строку для обнуления переменной[vba]
Код
iNumFiles1=0
[/vba] ибо счетчик при повторном запуске продолжал считать
Спасибо, сейчас и Ваш вариант протестирую

Автор - Sancho
Дата добавления - 18.08.2016 в 12:16
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перебор файлов в папках и в подпапках (Макросы/Sub)
Страница 1 из 11
Поиск:

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