Всем привет. Есть макрос, который производит сбор данных с файлов которые лежат в этой же папке. Нужно переделать код, что бы перебирал все файлы в общей папке, где лежит файл с этим макросом, и в подпапках. Количество этих подпапок может быть разное. [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]
Всем привет. Есть макрос, который производит сбор данных с файлов которые лежат в этой же папке. Нужно переделать код, что бы перебирал все файлы в общей папке, где лежит файл с этим макросом, и в подпапках. Количество этих подпапок может быть разное. [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]
Код
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
sboy, спасибо, пришлось еще немного поковырять, что бы заработало. теперь не могу сообразить как заставить считать нормально счетчик файлов, что бы отобразить в сообщении сколько файлов было обработано по окончании работы макроса. Сейчас [vba]
Код
iNumFiles = iNumFiles + 1
[/vba]считает сколько файлов открыл при исполнении последнего цикла перебора файлов, т.е. в последней папке.
sboy, спасибо, пришлось еще немного поковырять, что бы заработало. теперь не могу сообразить как заставить считать нормально счетчик файлов, что бы отобразить в сообщении сколько файлов было обработано по окончании работы макроса. Сейчас [vba]
Код
iNumFiles = iNumFiles + 1
[/vba]считает сколько файлов открыл при исполнении последнего цикла перебора файлов, т.е. в последней папке.Sancho
Sancho, тут мне трудно без испытаний макроса) как вариант выводить сообщение с количеством файлов после обработки каждой папки, но думаю что это вам не нужно...
Sancho, тут мне трудно без испытаний макроса) как вариант выводить сообщение с количеством файлов после обработки каждой папки, но думаю что это вам не нужно...sboy