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 для додатків вікна, натисніть Insert > Модулі. Потім скопіюйте нижче код 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 усього аркуша1 будуть скопійовані в основний аркуш. І “Новий аркуш”- ім’я новоствореного головного аркуша.
2). Файли Excel у певній папці не повинні відкриватися.

3 Натисніть кнопку F5 клавіша для запуску коду.

4. На відкритті перегорнути вікно, виберіть папку, яка містить файли, через які ви проходите цикл, а потім клацніть на OK кнопку. Дивіться знімок екрана:

Потім у кінці поточної книги створюється головний аркуш із назвою "Новий аркуш". А дані в діапазоні A1: D4 усіх аркушів1 у вибраній папці перераховані всередині робочого аркуша.


Статті по темі:


Найкращі інструменти для підвищення продуктивності офісу

Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%

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

Вкладка Office забезпечує інтерфейс з вкладками для Office і значно спрощує вашу роботу

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

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem як варіант
Dim xFileDlg як FileDialog
Dim xFileName, xSheetName, xRgStr як рядок
Dim xBook, xWorkBook як робочий зошит
Dim xSheet як робочий аркуш
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Невірний
xSheetName = "Аркуш1"
xRgStr = "A1:D4"
Встановіть xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
За допомогою xFileDlg
Якщо .Show = -1 Тоді
xSelItem = .SelectedItems.Item(1)
Встановіть xWorkBook = This Workbook
Встановіть 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 = Dir()
xBook.Закрити
Петля
End If
Кінець з
Встановіть xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Цей коментар був мінімізований модератором на сайті
Привіт, дякую за код. Скажіть, будь ласка, як я можу включити ім’я файлу Excel, з якого було скопійовано діапазон даних? Це була б велика допомога!

Дякую.
Цей коментар був мінімізований модератором на сайті
Здравствуйте,

Дякую за підручник.

Як би я: скопіюйте лише рядок у "Sheet1" зі значеннями з рядка "total" і вставте з [ім'я файлу] в основний аркуш під назвою "New Sheet". Відмітка рядка з Усього може відрізнятися на кожному робочому аркуші.

Наприклад:
Файл 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 As Range
Dim xSelItem як варіант
Dim xFileDlg як FileDialog
Dim xFileName, xSheetName, xRgStr як рядок
Dim xBook, xWorkBook як робочий зошит
Dim xSheet як робочий аркуш
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Невірний
xSheetName = "Аркуш1"
xRgStr = "A1:D4"
Встановіть xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
За допомогою xFileDlg
Якщо .Show = -1 Тоді
xSelItem = .SelectedItems.Item(1)
Встановіть xWorkBook = This Workbook
Встановіть 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 = Dir()
xBook.Закрити
Петля
End If
Кінець з
Встановіть xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
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 As Range
Dim xSelItem як варіант
Dim xFileDlg як FileDialog
Dim xFileName, xSheetName, xRgStr як рядок
Dim xBook, xWorkBook як робочий зошит
Dim xSheet як робочий аркуш
Dim xShs як листи
Dim xName як рядок
Dim xFNum як ціле число
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Невірний
Встановіть 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, "лист""таб") 'Замінити аркуш на вкладку
xSheet.Name = xName
Далі
xWorkBook.Save
xWorkBook.Close
xFileName = Dir()
Петля
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Цей коментар був мінімізований модератором на сайті
Привіт, мені потрібен код для копіювання даних із 6 різних робочих книг (у папці), які містять аркуші, до НОВОЇ РОБОЧОЇ КНИГИ. у vba
Plz допоможіть мені asp
Цей коментар був мінімізований модератором на сайті
Привіт Парануша,
Сценарій VBA в наведеній нижче статті може об’єднати кілька робочих книг або певних аркушів робочих книг у головну робочу книгу. Будь ласка, перевірте, чи може це допомогти.
Як об’єднати кілька робочих книг в одну головну книгу в Excel?
Цей коментар був мінімізований модератором на сайті
Olá bom dia.
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 для автоматизації essas impressões? Me ajudaria muito, obrigada.
Цей коментар був мінімізований модератором на сайті
Привіт, Марія Соарес,
Перевірте, чи може код VBA у наступній публікації допомогти.
Як надрукувати кілька книг у Excel?
Цей коментар був мінімізований модератором на сайті
Мій сценарій подібний, за винятком того, що я маю кілька аркушів у кожному файлі, усі з різними іменами, але узгодженими між файлами. Чи є спосіб зациклити цей код, щоб скопіювати дані у файлах і вставити (значення) до певних імен аркушів у головній книзі? Імена аркушів у шаблоні такі ж, як і у файлах. Я хочу їх переглянути. Крім того, кількість даних на кожному аркуші буде різною, тому мені потрібно буде вибрати дані на кожному аркуші за допомогою приблизно такого:

Діапазон ("A1"). Виберіть
Діапазон(Вибір, Вибір. Кінець(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
There are no comments posted here yet
Залишайте свої коментарі
Публікація як гість
×
Оцініть цю публікацію:
0   Персонажі
Рекомендовані місця

Слідуй за нами

Copyright © 2009 - WWW.extendoffice.com. | Всі права захищені. На основі ExtendOffice. | Карта сайту
Microsoft та логотип Office є товарними знаками або зареєстрованими товарними знаками Microsoft Corporation у США та / або інших країнах.
Захищений Sectigo SSL