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

Kako se vrteti po datotekah v imeniku in kopirati podatke v glavni list v Excelu?

Recimo, da je v mapi več Excelovih delovnih zvezkov in bi radi zavili vse te Excelove datoteke in kopirali podatke iz določenega obsega istoimenskih delovnih listov v glavni delovni list v Excelu, kaj lahko storite? Ta članek podrobno predstavlja metodo za njegovo doseganje.

Prelistajte datoteke v imeniku in kopirajte podatke v glavni list s kodo VBA


Prelistajte datoteke v imeniku in kopirajte podatke v glavni list s kodo VBA

Če želite kopirati določene podatke v obsegu A1: D4 iz vseh listov1 delovnih zvezkov v določeni mapi na glavni list, storite naslednje.

1. V delovnem zvezku boste ustvarili glavni delovni list, pritisnite druga + F11 tipke za odpiranje Microsoft Visual Basic za aplikacije okno.

2. V Ljubljani Microsoft Visual Basic za aplikacije okno, kliknite Vstavi > Moduli. Nato kopirajte spodnjo kodo VBA v okno s kodo.

Koda VBA: zavrtite datoteke v mapi in kopirajte podatke v glavni list

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

Opombe:

1). V kodi je "A1: D4"In"Sheet1"Pomeni, da se bodo podatki v obsegu A1: D4 vseh listov 1 kopirali v glavni list. In “Nov list"Je ime novega ustvarjenega glavnega lista.
2). Datoteke Excel v določeni mapi se ne smejo odpreti.

3. Pritisnite F5 tipko za zagon kode.

4. Na odprtju Brskanje v oknu izberite mapo, v kateri so datoteke, do katerih boste šli, in nato kliknite OK . Oglejte si posnetek zaslona:

Nato se na koncu trenutnega delovnega zvezka ustvari glavni delovni list z imenom »Nov list«. In podatki v obsegu A1: D4 vseh listov1 v izbrani mapi so navedeni na delovnem listu.


Sorodni članki:


Najboljša orodja za pisarniško produktivnost

Kutools za Excel rešuje večino vaših težav in poveča vašo produktivnost za 80%

  • Ponovna uporaba: Hitro vstavite zapletene formule, grafikoni in vse, kar ste že uporabljali; Šifriraj celice z geslom; Ustvari poštni seznam in pošiljanje e-pošte ...
  • Vrstica Super Formula (enostavno urejanje več vrstic besedila in formule); Bralna postavitev (enostavno branje in urejanje velikega števila celic); Prilepite v filtrirani obseg...
  • Združi celice / vrstice / stolpce brez izgube podatkov; Vsebina razdeljenih celic; Združi podvojene vrstice / stolpce... prepreči podvojene celice; Primerjaj obsege...
  • Izberite Duplicate ali Unique Vrstice; Izberite prazne vrstice (vse celice so prazne); Super Find in Fuzzy Find v mnogih delovnih zvezkih; Naključna izbira ...
  • Natančna kopija Več celic brez spreminjanja sklica formule; Samodejno ustvarjanje referenc na več listov; Vstavi oznake, Potrditvena polja in še več ...
  • Izvleček besedila, Dodaj besedilo, Odstrani po položaju, Odstrani presledek; Ustvari in natisni vmesne seštevke strani Pretvarjanje med vsebino celic in komentarji...
  • Super filter (shranite in uporabite sheme filtrov za druge liste); Napredno razvrščanje glede na mesec / teden / dan, pogostost in drugo; Poseben filter s krepko, ležeče ...
  • Združite delovne zvezke in delovne liste; Spoji tabele na podlagi ključnih stolpcev; Razdelite podatke na več listov; Paketna pretvorba xls, xlsx in PDF...
  • Več kot 300 zmogljivih funkcij. Podpira Office / Excel 2007-2021 in 365. Podpira vse jezike. Enostavna uvedba v vašem podjetju ali organizaciji. 30-dnevna brezplačna preizkusna različica vseh funkcij. 60-dnevna garancija vračila denarja.
zavihek kte 201905

Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo

  • Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
  • Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
  • Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!
dno pisarniške mize
Komentarji (20)
Ocene še ni. Bodite prvi in ​​ocenite!
Ta komentar je moderator na spletnem mestu minimiziral
hvala za vba kodo! Deluje odlično! Bi rad vedel, kakšna je koda, če moram namesto tega PRILEPITI KOT VREDNOST? Hvala vnaprej!
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Lai Ling,
Naslednja koda vam lahko pomaga rešiti težavo. Hvala za vaš komentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Zatemni xSelItem kot različico
Zatemni xFileDlg kot FileDialog
Dim xFileName, xSheetName, xRgStr kot niz
Dim xBook, xWorkBook kot delovni zvezek
Zatemni xSheet kot delovni list
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Napačno
xSheetName = "List1"
xRgStr = "A1:D4"
Nastavite xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Z xFileDlg
Če je .Show = -1 Potem
xSelItem = .SelectedItems.Item(1)
Nastavite xWorkBook = ThisWorkbook
Nastavite xSheet = xWorkBook.Sheets("Nov list")
Če potem xSheet ni nič
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nov list"
Nastavite xSheet = xWorkBook.Sheets("Nov list")
Konec Če
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Če je xFileName = "" Nato zapustite Sub
Naredi do xFileName = ""
Nastavi xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Nastavi xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Zapri
Zanka
Konec Če
Končaj s
Nastavite xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Res
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Aplikacija EnableEvents = True
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, hvala za kodo. Prosim, ali mi lahko sporočite, kako lahko vključim ime datoteke Excel, iz katere je bil kopiran obseg podatkov? To bi bila v veliko pomoč!

Hvala.
Ta komentar je moderator na spletnem mestu minimiziral
Zdravo,

Hvala za vadnico.

Kako bi: kopirajte samo vrstico v "Sheet1" z vrednostmi iz vrstice "skupaj" in prilepite z [ime datoteke] v glavni delovni list z imenom "Nov list". Opomba vrstice s Skupno se lahko razlikuje na vsakem delovnem listu.

Na primer:
Datoteka1: List1
Col1, Col2, Colx
1,2,15
Rezultat, 10,50

Datoteka2: List1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Rezultat, 300,500

MasterFile: "Nov list":
datoteka 1, 10, 50
datoteka 2, 300, 500
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, to deluje odlično. Ali obstaja način za spremembo, da preprosto povlečete vrednosti in ne formule?
Hvala !!
Ta komentar je moderator na spletnem mestu minimiziral
Živijo Trish,
Naslednja koda vam lahko pomaga rešiti težavo. Hvala za vaš komentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Zatemni xSelItem kot različico
Zatemni xFileDlg kot FileDialog
Dim xFileName, xSheetName, xRgStr kot niz
Dim xBook, xWorkBook kot delovni zvezek
Zatemni xSheet kot delovni list
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Napačno
xSheetName = "List1"
xRgStr = "A1:D4"
Nastavite xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Z xFileDlg
Če je .Show = -1 Potem
xSelItem = .SelectedItems.Item(1)
Nastavite xWorkBook = ThisWorkbook
Nastavite xSheet = xWorkBook.Sheets("Nov list")
Če potem xSheet ni nič
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nov list"
Nastavite xSheet = xWorkBook.Sheets("Nov list")
Konec Če
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Če je xFileName = "" Nato zapustite Sub
Naredi do xFileName = ""
Nastavi xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Nastavi xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFileName = Dir()
xBook.Zapri
Zanka
Konec Če
Končaj s
Nastavite xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Res
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Aplikacija EnableEvents = True
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, še vedno vleče formule, ne vrednosti, zato mi daje napako #REF. Vem, da bo morda nekje potreboval .PasteSpecial xlPasteValues, vendar ne morem ugotoviti, kje. Lahko pomagate? Hvala!
Ta komentar je moderator na spletnem mestu minimiziral
Pozdravljeni, hvala za to.


Kako vključim kodo za zanko skozi vse mape in podmape in izvedem zgornjo kopijo?


Hvala!
Ta komentar je moderator na spletnem mestu minimiziral
Živjo - ta koda je popolna za tisto, kar poskušam doseči.

Ali obstaja način, da prelistate vse mape in podmape in izvedete kopiranje?


Hvala!
Ta komentar je moderator na spletnem mestu minimiziral
Živjo - Ta koda deluje zelo dobro za prvih 565 vrstic za vsako datoteko, vendar se vse naslednje vrstice prekrivajo z naslednjo datoteko.
ali obstaja način, da to popravim?
Ta komentar je moderator na spletnem mestu minimiziral
Hvala - kako bi bilo mogoče kopirati in prilepiti (posebne vrednosti) iz vsakega delovnega lista v delovnem zvezku v ločene liste znotraj glavne glavne datoteke?
Ta komentar je moderator na spletnem mestu minimiziral
kako narediti, da koda pusti prazno, če je celica prazna?
Ta komentar je moderator na spletnem mestu minimiziral
zame se ime zavihka "Sheet1" spremeni za vsako od mojih datotek. Na primer, Tab1, Tab2, Tab3, Tab4 ... Kako lahko nastavim zanko, da teče po seznamu v excelu in še naprej spreminjam ime "Sheet1", dokler ne teče skozi vse?
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Nick, spodnja koda VBA ti lahko pomaga rešiti težavo. Prosim, poskusite. Sub LoopThroughFileRename()
'Posodobljeno z Extendofice 2021/12/31
Dim xRg As Range
Zatemni xSelItem kot različico
Zatemni xFileDlg kot FileDialog
Dim xFileName, xSheetName, xRgStr kot niz
Dim xBook, xWorkBook kot delovni zvezek
Zatemni xSheet kot delovni list
Dim xShs kot listi
Dim xName kot niz
Dim xFNum kot celo število
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = Napačno
Nastavite xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Naredi, medtem ko xFileName <> ""
Nastavite xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Nastavite xShs = xWorkBook.Sheets
Za xFNum = 1 do xShs.Count
Nastavi xSheet = xShs.Item(xFNum)
xIme = xSheet.Name
xName = Zamenjaj(xName, "List""Tab") 'Zamenjaj list z zavihkom
xSheet.Name = xName
Naslednji
xWorkBook.Save
xWorkBook.Zapri
xFileName = Dir()
Zanka
Application.DisplayAlerts = True
Aplikacija EnableEvents = True
Application.ScreenUpdating = Res
End Sub
Ta komentar je moderator na spletnem mestu minimiziral
Živjo, želim kodo za kopiranje podatkov v 6 različnih delovnih zvezkih (v mapi), ki vsebujejo liste, v NOV DELOVNI ZVEZEK. v vba
plz pomoč mi asp
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Paranusha,
Skript VBA v naslednjem članku lahko združi več delovnih zvezkov ali določene liste delovnih zvezkov v glavni delovni zvezek. Preverite, ali lahko pomaga.
Kako združiti več delovnih zvezkov v en glavni delovni zvezek v Excelu?
Ta komentar je moderator na spletnem mestu minimiziral
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. Pode me enviar um códgo de VBA que avtomatize essas impressões? Me ajudaria muito, obrigada.
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Maria Soares,
Preverite, ali lahko koda VBA v naslednji objavi pomaga.
Kako natisniti več delovnih zvezkov v Excelu?
Ta komentar je moderator na spletnem mestu minimiziral
Moj scenarij je podoben, le da imam v vsaki datoteki več listov, vsi z različnimi imeni, vendar med datotekami enakimi. Ali obstaja način za zanko te kode za kopiranje podatkov v datotekah in lepljenje (vrednosti) na določena imena listov v glavnem delovnem zvezku? Imena listov v masteru so enaka kot v datotekah. Želim jih pregledati. Poleg tega se bo količina podatkov na vsakem listu razlikovala, zato bom moral podatke na vsakem listu izbrati takole:

Obseg("A1").Izberi
Obseg(Izbor, Izbor.Konec(xlDown)).Izberi
Obseg(Izbor, Izbor.Konec(xlToRight)).Izberi


Imena listov datotek so Dajanje, Storitve, Zavarovanje, Avto, Drugi stroški itd.

Hvala vnaprej.
Ta komentar je moderator na spletnem mestu minimiziral
Živjo Andrew Shahan,
Naslednja koda VBA lahko reši vašo težavo. Ko zaženete kodo in izberete mapo, se bo koda samodejno ujemala z delovnim listom po imenu in prilepila podatke v istoimenski delovni list v glavnem delovnem zvezku.
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
Tu še ni objavljenih komentarjev
Pustite vaše komentarje
Objava kot gost
×
Ocenite to objavo:
0   Znaki
Predlagane lokacije

Sledi nam

Copyright © 2009 - www.extendoffice.com. | Vse pravice pridržane. Poganja ga ExtendOffice. | Kazalo
Microsoft in logotip Office sta blagovni znamki ali registrirani blagovni znamki družbe Microsoft Corporation v ZDA in / ali drugih državah.
Zaščiteno s Sectigo SSL