Как организовать циклический перебор файлов Excel в папке и скопировать данные из них на главный лист?
Предположим, в папке находятся несколько рабочих книг Excel, и вам нужно последовательно открыть все эти файлы, чтобы скопировать данные из определённого диапазона на одном и том же листе (например, «Лист1») в основной лист. В этом руководстве представлено подробное решение на языке VBA для автоматизации данного процесса в Excel.
Циклический перебор книг в папке и копирование данных на главный лист с помощью кода VBA
Циклический перебор файлов в папке и копирование данных на главный лист с помощью кода VBA
Если вы хотите скопировать данные из диапазона A1:D4 со всех листов «Лист1» книг, расположенных в определённой папке, и вставить их на главный лист, выполните следующие действия.
1. В книге, в которой вы создадите Основной лист, нажмите клавиши Alt+F11, чтобы открыть окно Microsoft Visual Basic for Applications.
2. В окне Microsoft Visual Basic for Applications выберите пункт Insert > Module, а затем скопируйте приведённый ниже код VBA в окно кода.
Код VBA: циклический перебор файлов в папке и копирование данных на главный лист
Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
If .Show = -1 Then
xSelItem = .SelectedItems.Item(1)
Set xWorkBook = ThisWorkbook
Set xSheet = xWorkBook.Sheets("New Sheet")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
Set xSheet = xWorkBook.Sheets("New Sheet")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
If xFileName = "" Then Exit Sub
Do Until xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Close
Loop
End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubПримечание:
3. Нажмите клавишу F5, чтобы запустить код.
4. В открывшемся окне Browse выберите папку, содержащую файлы для обработки, и нажмите кнопку OK. См. снимок экрана:
Затем в конец текущей книги добавляется основной лист с именем «New Sheet», на который помещаются данные из диапазона A1:D4 всех листов «Лист1», находящихся в выбранной папке.
Связанные статьи:
Лучшие инструменты повышения продуктивности в Office
Раскройте весь потенциал Excel с помощью Kutools для Excel и ощутите эффективность как никогда раньше.Kutools для Excel предлагает более 300 расширенных функций для повышения продуктивности и Экономия времени.Нажмите здесь, чтобы получить нужную Вам функцию…
Office Tab добавляет в Office вкладки и значительно упрощает Вашу работу
- Включите редактирование и чтение во вкладках в Word, Excel, PowerPoint, Publisher, Access, Visio и Project.
- Открывайте и создавайте несколько документов во вкладках одного окна — вместо того чтобы использовать отдельные окна.
- Повышает вашу продуктивность на 50 % и экономит сотни кликов мышью каждый день!
Все надстройки Kutools — один установщик
Kutools for Office — набор надстроек для Excel, Word, Outlook и PowerPoint, а также Office Tab Pro, идеально подходящий командам, работающим с разными приложениями Office.
- Единый комплект— надстройки для Excel, Word, Outlook и PowerPoint + Office Tab Pro
- Один установщик, одна лицензия— настройка занимает считанные минуты (готово для MSI)
- Лучше работать вместе— оптимизированная продуктивность во всех приложениях Office
- 30-дневная полнофункциональная пробная версия— без регистрации и кредитной карты
- Лучшее соотношение цены и качества— экономия по сравнению с покупкой отдельных надстроек