Note: The other languages of the website are Google-translated. Back to English

Как перебирать файлы в каталоге и копировать данные в мастер-лист в Excel?

Предположим, что в папке есть несколько книг Excel, и вы хотите перебрать все эти файлы Excel и скопировать данные из указанного диапазона листов с одинаковыми именами в главный рабочий лист в Excel, что вы можете сделать? В этой статье подробно описывается метод достижения этой цели.

Перебирайте файлы в каталоге и копируйте данные в мастер-лист с кодом VBA


Перебирайте файлы в каталоге и копируйте данные в мастер-лист с кодом VBA

Если вы хотите скопировать указанные данные в диапазоне A1: D4 со всех листов 1 книг в определенной папке на мастер-лист, сделайте следующее.

1. В книге вы создадите мастер-лист, нажмите кнопку другой + F11 , чтобы открыть Microsoft Visual Basic для приложений окно.

2. в Microsoft Visual Basic для приложений окна, нажмите Вставить > Модули. Затем скопируйте ниже код 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

Внимание:

1). В коде "A1: D4(Основной ключ) и Sheet1”Означают, что данные в диапазоне A1: D4 всего Sheet1 будут скопированы в мастер-лист. И "Новый лист»- это имя нового созданного мастер-листа.
2). Файлы Excel в определенной папке открываться не должны.

3. нажмите F5 ключ для запуска кода.

4. В дебюте Приложения в окне выберите папку, содержащую файлы, которые вы будете просматривать, а затем щелкните OK кнопка. Смотрите скриншот:

Затем в конце текущей книги создается главный рабочий лист с именем «Новый лист». И данные в диапазоне A1: D4 всех Sheet1 в выбранной папке перечислены внутри рабочего листа.


Статьи по теме:


Лучшие инструменты для работы в офисе

Kutools for Excel решает большинство ваших проблем и увеличивает вашу производительность на 80%

  • Снова использовать: Быстро вставить сложные формулы, диаграммы и все, что вы использовали раньше; Зашифровать ячейки с паролем; Создать список рассылки и отправлять электронные письма ...
  • Бар Супер Формулы (легко редактировать несколько строк текста и формул); Макет для чтения (легко читать и редактировать большое количество ячеек); Вставить в отфильтрованный диапазон...
  • Объединить ячейки / строки / столбцы без потери данных; Разделить содержимое ячеек; Объединить повторяющиеся строки / столбцы... Предотвращение дублирования ячеек; Сравнить диапазоны...
  • Выберите Дубликат или Уникальный Ряды; Выбрать пустые строки (все ячейки пустые); Супер находка и нечеткая находка во многих рабочих тетрадях; Случайный выбор ...
  • Точная копия Несколько ячеек без изменения ссылки на формулу; Автоматическое создание ссылок на несколько листов; Вставить пули, Флажки и многое другое ...
  • Извлечь текст, Добавить текст, Удалить по позиции, Удалить пробел; Создание и печать промежуточных итогов по страницам; Преобразование содержимого ячеек в комментарии...
  • Суперфильтр (сохранять и применять схемы фильтров к другим листам); Расширенная сортировка по месяцам / неделям / дням, периодичности и др .; Специальный фильтр жирным, курсивом ...
  • Комбинируйте книги и рабочие листы; Объединить таблицы на основе ключевых столбцов; Разделить данные на несколько листов; Пакетное преобразование xls, xlsx и PDF...
  • Более 300 мощных функций. Поддерживает Office/Excel 2007-2021 и 365. Поддерживает все языки. Простое развертывание на вашем предприятии или в организации. Полнофункциональная 30-дневная бесплатная пробная версия. 60-дневная гарантия возврата денег.
вкладка kte 201905

Вкладка Office: интерфейс с вкладками в Office и упрощение работы

  • Включение редактирования и чтения с вкладками в Word, Excel, PowerPoint, Издатель, доступ, Visio и проект.
  • Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
  • Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!
офисный дно
Сортировать комментарии по
Комментарии (20)
Оценок пока нет. Оцените первым!
Этот комментарий был сведен к минимуму модератором на сайте
спасибо за код vba! Он работает отлично! Хотел бы знать, что такое код, если мне нужно вместо этого ВСТАВИТЬ КАК ЗНАЧЕНИЕ? Спасибо заранее!
Этот комментарий был сведен к минимуму модератором на сайте
Привет Лай Линг,
Следующий код может помочь вам решить проблему. Спасибо за ваш комментарий.

Sub Merge2MultiSheets()
Dim xRg как диапазон
Dim xSelItem как вариант
Dim xFileDlg как FileDialog
Dim xFileName, xSheetName, xRgStr как строка
Dim xBook, xWorkBook как рабочая книга
Dim xSheet как рабочий лист
On Error Resume Next
Приложение.DisplayAlerts = False
Application.EnableEvents = False
Приложение.ScreenUpdating = False
xSheetName = "Лист1"
xRgStr = "A1:D4"
Установите xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
С xFileDlg
Если .Показать = -1 Тогда
xSelItem = .ВыбранныеЭлементы.Элемент(1)
Установите xWorkBook = ThisWorkbook
Установить xSheet = xWorkBook.Sheets("Новый лист")
Если xSheet ничего, тогда
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Новый лист"
Установить xSheet = xWorkBook.Sheets("Новый лист")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Если xFileName = "", то выйдите из Sub
Делать до тех пор, пока xFileName = ""
Установить xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Установить xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Каталог()
xBook.Закрыть
Петля
End If
Конец с
Установите xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Истина
xRg.UseStandardWidth = Истина
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Привет, спасибо за код. Пожалуйста, дайте мне знать, как я могу включить имя файла Excel, из которого был скопирован диапазон данных? Это было бы большим подспорьем!

Спасибо.
Этот комментарий был сведен к минимуму модератором на сайте
Здравствуйте,

Спасибо за урок.

Как бы я: Скопируйте только строку в «Лист1» со значениями из «итоговой» строки и вставьте с [имя файла] в основной рабочий лист с именем «Новый лист». Отметка строки с Итогом может быть разной на каждом листе.

Например:
Файл1: Лист1
Col1, Col2, Colx
1,2,15
Результат,10,50

Файл2: Лист1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Результат,300,500

MasterFile: «Новый лист»:
файл1, 10, 50
файл2, 300, 500
Этот комментарий был сведен к минимуму модератором на сайте
Привет, это прекрасно работает. Есть ли способ изменить, чтобы просто перетаскивать значения, а не формулу?
Благодаря!!
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Триш,
Следующий код может помочь вам решить проблему. Спасибо за ваш комментарий.

Sub Merge2MultiSheets()
Dim xRg как диапазон
Dim xSelItem как вариант
Dim xFileDlg как FileDialog
Dim xFileName, xSheetName, xRgStr как строка
Dim xBook, xWorkBook как рабочая книга
Dim xSheet как рабочий лист
On Error Resume Next
Приложение.DisplayAlerts = False
Application.EnableEvents = False
Приложение.ScreenUpdating = False
xSheetName = "Лист1"
xRgStr = "A1:D4"
Установите xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
С xFileDlg
Если .Показать = -1 Тогда
xSelItem = .ВыбранныеЭлементы.Элемент(1)
Установите xWorkBook = ThisWorkbook
Установить xSheet = xWorkBook.Sheets("Новый лист")
Если xSheet ничего, тогда
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Новый лист"
Установить xSheet = xWorkBook.Sheets("Новый лист")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Если xFileName = "", то выйдите из Sub
Делать до тех пор, пока xFileName = ""
Установить xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Установить xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Каталог()
xBook.Закрыть
Петля
End If
Конец с
Установите xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Истина
xRg.UseStandardWidth = Истина
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Привет, он по-прежнему извлекает формулы, а не значения, поэтому выдает ошибку #REF. Я знаю, что где-то может понадобиться .PasteSpecial xlPasteValues, но я не могу понять, где. Вы можете помочь? Спасибо!
Этот комментарий был сведен к минимуму модератором на сайте
Привет Спасибо за это.


Как мне включить код для перебора всех папок и подпапок и выполнения указанной выше копии?


Благодаря!
Этот комментарий был сведен к минимуму модератором на сайте
Привет. Этот код идеально подходит для того, чего я пытаюсь достичь.

Есть ли способ просмотреть все папки и подпапки и выполнить копирование?


Благодаря!
Этот комментарий был сведен к минимуму модератором на сайте
Привет. Этот код очень хорошо работает для первых 565 строк каждого файла, но все последующие строки перекрываются следующим файлом.
Есть ли способ исправить это?
Этот комментарий был сведен к минимуму модератором на сайте
Спасибо - как можно копировать и вставлять (специальные значения) из каждого рабочего листа в рабочей книге на отдельные листы в основном мастер-файле?
Этот комментарий был сведен к минимуму модератором на сайте
как заставить код оставить пустым, если ячейка пуста?
Этот комментарий был сведен к минимуму модератором на сайте
для меня имя вкладки «Лист1» меняется для каждого из моих файлов. Например, Tab1, Tab2, Tab3, Tab4... Как я могу настроить цикл для прохождения списка в Excel и продолжать менять имя «Лист1», пока он не пройдет все?
Этот комментарий был сведен к минимуму модератором на сайте
Привет Ник, приведенный ниже код VBA может помочь вам решить проблему. Пожалуйста, попробуйте. Sub LoopThroughFileRename()
'Обновлено Extendofice 2021/12/31
Dim xRg как диапазон
Dim xSelItem как вариант
Dim xFileDlg как FileDialog
Dim xFileName, xSheetName, xRgStr как строка
Dim xBook, xWorkBook как рабочая книга
Dim xSheet как рабочий лист
Разм. xШс как листы
Dim xName как строка
Dim xFNum как целое число
On Error Resume Next
Приложение.DisplayAlerts = False
Application.EnableEvents = False
Приложение.ScreenUpdating = False
Установите xFileDlg = Application.FileDialog (msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Делать, пока xFileName <> ""
Установите xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Установите xShs = xWorkBook.Sheets
Для xFNum = 1 To xShs.Count
Установить xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = Заменить(xName, "Простыня,Tab") 'Заменить лист вкладкой
xSheet.Name = xName
Далее
xWorkBook.Сохранить
xWorkBook.Close
xFileName = Каталог()
Петля
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Этот комментарий был сведен к минимуму модератором на сайте
Привет, мне нужен код для копирования данных в 6 разных книгах (в папке), в которые включены листы, в НОВУЮ РАБОЧУЮ КНИГУ. в ВБА
пожалуйста, помогите мне, асп
Этот комментарий был сведен к минимуму модератором на сайте
Привет, Паранюша.
Сценарий VBA, описанный в следующей статье, может объединить несколько книг или указанных листов книг в главную книгу. Пожалуйста, проверьте, может ли это помочь.
Как объединить несколько книг в одну главную книгу в Excel?
Этот комментарий был сведен к минимуму модератором на сайте
Ола бом диа.
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes e não estão configuradas corretamente para impressão. Как мне использовать код VBA, который автоматизирует ваши впечатления? Me ajudaria muito, obrigada.
Этот комментарий был сведен к минимуму модератором на сайте
Здравствуйте, Мария Соареш.
Пожалуйста, проверьте, может ли помочь код VBA в следующем посте.
Как распечатать несколько книг в Excel?
Этот комментарий был сведен к минимуму модератором на сайте
Мой сценарий аналогичен, за исключением того, что у меня есть несколько листов в каждом файле, все с разными именами, но одинаковыми между файлами. Есть ли способ зациклить этот код, чтобы скопировать данные в файлы и вставить (значения) в определенные имена листов в главной книге? Имена листов в мастере такие же, как и в файлах. Я хочу пройтись по ним. Кроме того, количество данных на каждом листе будет разным, поэтому мне нужно будет выбрать данные на каждом листе, используя что-то вроде этого:

Диапазон ("A1"). Выбрать
Диапазон (Selection, Selection.End (xlDown)). Выберите
Диапазон (Выделение, Выбор. Конец (xlToRight)). Выберите


Имена файловых листов: Предоставление, Услуги, Страхование, Автомобиль, Другие расходы и т. Д.

Заранее спасибо.
Этот комментарий был сведен к минимуму модератором на сайте
Привет Андрей Шахан,
Следующий код VBA может решить вашу проблему. После запуска кода и выбора папки код автоматически сопоставит рабочий лист по имени и вставит данные в рабочий лист с тем же именем в главной книге.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Здесь еще нет комментариев
Оставляйте свои комментарии
Публикация как гость
×
Оценить этот пост:
0   Характеристики
Предлагаемые места

Подписывайтесь на Нас

Copyright © 2009 - www.extendoffice.ком. | Все права защищены. Питаться от ExtendOffice, | Карта сайта
Microsoft и логотип Office являются товарными знаками или зарегистрированными товарными знаками Microsoft Corporation в США и / или других странах.
Защищено Sectigo SSL