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

Jak przeglądać pliki w katalogu i kopiować dane do arkusza wzorcowego w programie Excel?

Przypuśćmy, że w folderze znajduje się wiele skoroszytów programu Excel i chcesz przejrzeć wszystkie te pliki programu Excel i skopiować dane z określonego zakresu arkuszy o tej samej nazwie do głównego arkusza w programie Excel, co możesz zrobić? W tym artykule szczegółowo przedstawiono metodę osiągnięcia tego celu.

Przeglądaj pliki w katalogu i kopiuj dane do arkusza wzorcowego z kodem VBA


Przeglądaj pliki w katalogu i kopiuj dane do arkusza wzorcowego z kodem VBA

Jeśli chcesz skopiować określone dane z zakresu A1: D4 ze wszystkich skoroszytów arkusza 1 w określonym folderze do arkusza głównego, wykonaj następujące czynności.

1. W skoroszycie utworzysz główny arkusz roboczy, naciśnij inny + F11 klawisze, aby otworzyć Microsoft Visual Basic for Applications okno.

2. w Microsoft Visual Basic for Applications okno, kliknij wstawka > Moduł. Następnie skopiuj poniższy kod VBA do okna kodu.

Kod VBA: przeglądaj pliki w folderze i kopiuj dane do arkusza głównego

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

Uwagi:

1). W kodzie „A1: D4"I"Sheet1”Oznacza, że ​​dane w zakresie A1: D4 całego arkusza Sheet1 zostaną skopiowane do arkusza głównego. I "Nowy arkusz”To nazwa nowo utworzonego arkusza wzorcowego.
2). Pliki programu Excel w określonym folderze nie powinny się otwierać.

3. wciśnij F5 klucz do uruchomienia kodu.

4. W otwarciu Przeglądaj wybierz folder zawierający pliki, które chcesz przeglądać, a następnie kliknij OK przycisk. Zobacz zrzut ekranu:

Następnie na końcu bieżącego skoroszytu tworzony jest główny arkusz o nazwie „Nowy arkusz”. Dane w zakresie A1: D4 wszystkich Arkusz1 w wybranym folderze są wymienione w arkuszu.


Podobne artykuły:


Najlepsze narzędzia biurowe

Kutools dla programu Excel rozwiązuje większość problemów i zwiększa produktywność o 80%

  • Ponowne użycie: Szybko włóż złożone wzory, wykresy i wszystko, czego używałeś wcześniej; Szyfruj komórki z hasłem; Utwórz listę mailingową i wysyłaj e-maile ...
  • Pasek Super Formula (łatwo edytować wiele wierszy tekstu i formuły); Układ do czytania (łatwe odczytywanie i edytowanie dużej liczby komórek); Wklej do filtrowanego zakresu...
  • Scal komórki / wiersze / kolumny bez utraty danych; Podziel zawartość komórek; Połącz zduplikowane wiersze / kolumny... Zapobiegaj zduplikowanym komórkom; Porównaj zakresy...
  • Wybierz Duplikat lub Unikalny Wydziwianie; Wybierz puste wiersze (wszystkie komórki są puste); Super Find i Fuzzy Find w wielu zeszytach ćwiczeń; Losowy wybór ...
  • Dokładna kopia Wiele komórek bez zmiany odwołania do formuły; Automatyczne tworzenie odniesień do wielu arkuszy; Wstaw punktory, Pola wyboru i nie tylko ...
  • Wyodrębnij tekst, Dodaj tekst, Usuń według pozycji, Usuń przestrzeń; Tworzenie i drukowanie podsumowań stronicowania; Konwertuj zawartość komórek i komentarze...
  • Super filtr (zapisz i zastosuj schematy filtrów do innych arkuszy); Zaawansowane sortowanie według miesiąca / tygodnia / dnia, częstotliwości i innych; Specjalny filtr pogrubieniem, kursywą ...
  • Połącz skoroszyty i arkusze robocze; Scal tabele na podstawie kluczowych kolumn; Podziel dane na wiele arkuszy; Konwersja wsadowa xls, xlsx i PDF...
  • Ponad 300 zaawansowanych funkcji. Obsługuje Office / Excel 2007-2021 i 365. Obsługuje wszystkie języki. Łatwe wdrażanie w przedsiębiorstwie lub organizacji. Pełne funkcje 30-dniowa bezpłatna wersja próbna. 60-dniowa gwarancja zwrotu pieniędzy.
karta kte 201905

Karta Office wprowadza interfejs z zakładkami do pakietu Office i znacznie ułatwia pracę

  • Włącz edycję i czytanie na kartach w programach Word, Excel, PowerPoint, Publisher, Access, Visio i Project.
  • Otwieraj i twórz wiele dokumentów w nowych kartach tego samego okna, a nie w nowych oknach.
  • Zwiększa produktywność o 50% i redukuje setki kliknięć myszką każdego dnia!
officetab dół
Sortuj komentarze według
Komentarze (20)
Brak ocen. Oceń jako pierwszy!
Ten komentarz został zminimalizowany przez moderatora na stronie
dziękuję za kod vba! Działa idealnie! Czy chcesz wiedzieć, jaki jest kod, jeśli zamiast tego muszę WKLEJ JAKO WARTOŚĆ? Z góry dzięki!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Lai Ling,
Poniższy kod może pomóc w rozwiązaniu problemu. Dziękuję za Twój komentarz.

Sub Merge2MultiSheets()
Dim xRg jako zakres
Dim xSelItem jako wariant
Dim xFileDlg jako okno pliku
Dim xFileName, xSheetName, xRgStr jako ciąg
Dim xBook, xWorkBook jako skoroszyt
Dim xSheet jako arkusz roboczy
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = Fałsz
Application.ScreenUpdating = Fałsz
xSheetName = "Arkusz1"
xRgStr = "A1:D4"
Ustaw xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Z xFileDlg
Jeśli .Show = -1 Wtedy
xSelItem = .Wybrane elementy. Przedmiot(1)
Ustaw xWorkBook = ThisWorkbook
Ustaw xSheet = xWorkBook.Sheets("Nowy arkusz")
Jeśli xSheet to nic, wtedy
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nowy arkusz"
Ustaw xSheet = xWorkBook.Sheets("Nowy arkusz")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Jeśli xFileName = "" Następnie wyjdź z Sub
Wykonaj dopóki xFileName = ""
Ustaw xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ustaw xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xNazwaPliku = Katalog()
xBook.Zamknij
Pętla
End If
Kończyć z
Ustaw xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Prawda
xRg.UseStandardWidth = Prawda
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, dzięki za kod. Proszę o informację, w jaki sposób mogę dołączyć nazwę pliku Excel, z którego został skopiowany zakres danych? To byłaby wielka pomoc!

Dziękuję Ci.
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć,

Dziękuję Ci za tutorial.

Jak bym: Skopiuj tylko wiersz w „Arkuszu1” z wartościami z wiersza „ogółem” i wklej z [nazwa pliku] w głównym arkuszu roboczym o nazwie „Nowy arkusz”. Zauważenie, że wiersz z sumą może być inny w każdym arkuszu.

Na przykład:
Plik1: Arkusz1
Kol1, Kol2, Kolx
1,2,15
Wynik,10,50

Plik2: Arkusz1
Kol1, Kol2, Kolx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Wynik,300,500

MasterFile: „Nowy arkusz”:
plik1, 10, 50
plik2, 300, 500
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, to działa świetnie. Czy istnieje sposób na zmianę, aby po prostu przeciągnąć wartości, a nie formułę?
Dzięki !!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Trish,
Poniższy kod może pomóc w rozwiązaniu problemu. Dziękuję za Twój komentarz.

Sub Merge2MultiSheets()
Dim xRg jako zakres
Dim xSelItem jako wariant
Dim xFileDlg jako okno pliku
Dim xFileName, xSheetName, xRgStr jako ciąg
Dim xBook, xWorkBook jako skoroszyt
Dim xSheet jako arkusz roboczy
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = Fałsz
Application.ScreenUpdating = Fałsz
xSheetName = "Arkusz1"
xRgStr = "A1:D4"
Ustaw xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Z xFileDlg
Jeśli .Show = -1 Wtedy
xSelItem = .Wybrane elementy. Przedmiot(1)
Ustaw xWorkBook = ThisWorkbook
Ustaw xSheet = xWorkBook.Sheets("Nowy arkusz")
Jeśli xSheet to nic, wtedy
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nowy arkusz"
Ustaw xSheet = xWorkBook.Sheets("Nowy arkusz")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Jeśli xFileName = "" Następnie wyjdź z Sub
Wykonaj dopóki xFileName = ""
Ustaw xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ustaw xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xNazwaPliku = Katalog()
xBook.Zamknij
Pętla
End If
Kończyć z
Ustaw xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Prawda
xRg.UseStandardWidth = Prawda
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, nadal pobiera formuły, a nie wartości, więc daje mi błąd #REF. Wiem, że może potrzebować gdzieś .PasteSpecial xlPasteValues, ale nie mogę ustalić, gdzie. Możesz pomóc? Dzięki!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Dzięki za to.


Jak dołączyć kod, aby przejść przez wszystkie foldery i podfoldery i wykonać powyższą kopię?


Dzięki!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć - Ten kod jest idealny do tego, co staram się osiągnąć.

Czy istnieje sposób, aby przejść przez wszystkie foldery i podfoldery i wykonać kopię?


Dzięki!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć — ten kod działa bardzo dobrze dla pierwszych 565 wierszy dla każdego pliku, ale wszystkie następne wiersze nakładają się na następny plik.
czy istnieje sposób to naprawić?
Ten komentarz został zminimalizowany przez moderatora na stronie
Dziękuję — jak można skopiować i wkleić (wartości specjalne) z każdego arkusza roboczego w skoroszycie do oddzielnych arkuszy w głównym pliku głównym?
Ten komentarz został zminimalizowany przez moderatora na stronie
jak sprawić, by kod pozostawił puste, jeśli komórka jest pusta?
Ten komentarz został zminimalizowany przez moderatora na stronie
dla mnie nazwa zakładki „Arkusz1” zmienia się dla każdego z moich plików. Na przykład Tab1, Tab2, Tab3, Tab4... Jak mogę skonfigurować pętlę, aby przechodziła przez listę w programie Excel i ciągle zmieniać nazwę „Arkusz1”, dopóki nie przejdzie przez wszystko?
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Nick, Poniższy kod VBA może pomóc w rozwiązaniu problemu. Proszę spróbować. Zmiana nazwy pliku podrzędnego przez pętlę()
„Zaktualizowano przez Extendofice 2021/12/31”
Dim xRg jako zakres
Dim xSelItem jako wariant
Dim xFileDlg jako okno pliku
Dim xFileName, xSheetName, xRgStr jako ciąg
Dim xBook, xWorkBook jako skoroszyt
Dim xSheet jako arkusz roboczy
Dim xShs jako arkusze
Dim xName jako ciąg
Dim xFNum jako liczba całkowita
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = Fałsz
Application.ScreenUpdating = Fałsz
Ustaw xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Wykonaj, gdy xFileName <> ""
Ustaw xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ustaw xShs = xPraca.Arkusze
Dla xFNum = 1 To xShs.Count
Ustaw xSheet = xShs.Item(xFNum)
xNazwa = xNazwa.arkusza
xName = Zamień(xName, "arkusz""zakładka") 'Zamień arkusz na Tab
xSheet.Nazwa = xNazwa
Dalej
xWorkBook.Zapisz
xWorkBook.Zamknij
xNazwaPliku = Katalog()
Pętla
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć, chcę, aby kod do kopiowania danych z 6 różnych skoroszytów (w folderze) zawierał arkusze do NOWEGO SKOROSZYTU. w vba
proszę pomóż mi asp
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Paranusha,
Skrypt VBA w poniższym artykule może łączyć wiele skoroszytów lub określonych arkuszy skoroszytów z głównym skoroszytem. Sprawdź, czy to może pomóc.
Jak połączyć wiele skoroszytów w jeden główny skoroszyt w programie Excel?
Ten komentarz został zminimalizowany przez moderatora na stronie
Olá bom dia.
Gostei muito dessde codigo, 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. Pode me enviar um códgo de VBA que automatize essas impresões? Me ajudaria muito, obrigada.
Ten komentarz został zminimalizowany przez moderatora na stronie
Witaj Maria Soares,
Sprawdź, czy kod VBA w poniższym poście może pomóc.
Jak wydrukować wiele skoroszytów w programie Excel?
Ten komentarz został zminimalizowany przez moderatora na stronie
Mój scenariusz jest podobny, z wyjątkiem tego, że w każdym pliku mam wiele arkuszy, wszystkie o różnych nazwach, ale spójne między plikami. Czy istnieje sposób na zapętlenie tego kodu w celu skopiowania danych w plikach i wklejenia (wartości) do określonych nazw arkuszy w głównym skoroszycie? Nazwy arkuszy we wzorcu są takie same jak w plikach. Chcę przez nie przejść. Ponadto ilość danych w każdym arkuszu będzie się różnić, więc będę musiał wybrać dane w każdym arkuszu, używając czegoś takiego:

Zakres ("A1"). Wybierz
Zakres (Wybór, Wybór. Koniec (xlDown)). Wybierz
Zakres(Wybór, Zaznaczenie.Koniec(xlDo prawej)).Wybierz


Nazwy arkuszy plików to Dawanie, Usługi, Ubezpieczenie, Samochód, Inne wydatki itp.

Z góry dziękuję.
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Andrew Shahan,
Poniższy kod VBA może rozwiązać Twój problem. Po uruchomieniu kodu i wybraniu folderu kod automatycznie dopasuje nazwę do arkusza i wklei dane do arkusza o tej samej nazwie w głównym skoroszycie.
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
Nie ma tu jeszcze żadnych komentarzy
Zostaw swój komentarz
Publikowanie jako gość
×
Oceń ten post:
0   Postacie
Sugerowane lokalizacje

Bądż na bieżąco

Prawa autorskie © 2009 - www.extendoffice.com. | Wszelkie prawa zastrzeżone. Zasilany przez ExtendOffice, | Mapa strony
Microsoft i logo Office są znakami towarowymi lub zastrzeżonymi znakami towarowymi Microsoft Corporation w Stanach Zjednoczonych i / lub innych krajach.
Chronione przez Sectigo SSL