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

Hvordan går jeg igennem filer i et bibliotek og kopierer data til et masterark i Excel?

Antag at der er flere Excel-projektmapper i en mappe, og du vil løbe igennem alle disse Excel-filer og kopiere data fra det angivne område med samme navnearkeark til et hovedark i Excel, hvad kan du gøre? Denne artikel introducerer en metode til at opnå det i detaljer.

Loop gennem filer i et bibliotek, og kopier data til et masterark med VBA-kode


Loop gennem filer i et bibliotek, og kopier data til et masterark med VBA-kode

Hvis du vil kopiere angivne data i området A1: D4 fra alle ark1 med projektmapper i en bestemt mappe til et hovedark, skal du gøre som følger.

1. I projektmappen opretter du et hovedark, tryk på andre + F11 nøgler til at åbne Microsoft Visual Basic til applikationer vindue.

2. i Microsoft Visual Basic til applikationer vindue, skal du klikke på indsatte > Moduler. Kopier derefter under VBA-koden i kodevinduet.

VBA-kode: løb gennem filer i en mappe og kopier data til et masterark

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

Bemærk:

1). I koden, “A1: D4"Og"Sheet1”Betyder, at data i området A1: D4 for hele Ark1 kopieres til masterarket. Og “Nyt ark”Er navnet på det nyoprettede masterark.
2). Excel-filerne i den specifikke mappe bør ikke åbnes.

3. Tryk på F5 nøgle for at køre koden.

4. I åbningen Gennemse vindue, skal du vælge den mappe, der indeholder de filer, du vil løbe igennem, og derefter klikke på OK knap. Se skærmbillede:

Derefter oprettes et hovedark med navnet "Nyt ark" i slutningen af ​​den aktuelle projektmappe. Og data i rækkevidde A1: D4 for alt ark1 i den valgte mappe er angivet inde i regnearket.


Relaterede artikler:


De bedste Office-produktivitetsværktøjer

Kutools til Excel løser de fleste af dine problemer og øger din produktivitet med 80%

  • Genbruge: Indsæt hurtigt komplekse formler, diagrammer og alt, hvad du har brugt før; Krypter celler med adgangskode Opret postliste og send e-mails ...
  • Super formel bar (let redigere flere linjer med tekst og formel); Læsning Layout (let at læse og redigere et stort antal celler); Indsæt til filtreret rækkevidde...
  • Flet celler / rækker / kolonner uden at miste data; Split celler indhold; Kombiner duplikerede rækker / kolonner... Forhindre duplikerede celler; Sammenlign områder...
  • Vælg Duplicate eller Unique Rækker; Vælg tomme rækker (alle celler er tomme); Super Find og Fuzzy Find i mange arbejdsbøger; Tilfældig valg ...
  • Præcis kopi Flere celler uden at ændre formelreference; Auto Opret referencer til flere ark; Indsæt kugler, Afkrydsningsfelter og mere ...
  • Uddrag tekst, Tilføj tekst, Fjern efter position, Fjern mellemrum; Opret og udskriv personsøgningssubtotaler; Konverter mellem celler indhold og kommentarer...
  • Superfilter (gem og anvend filterskemaer på andre ark); Avanceret sortering efter måned / uge / dag, hyppighed og mere; Specielt filter af fed, kursiv ...
  • Kombiner arbejdsbøger og arbejdsark; Fletabeller baseret på nøglekolonner; Opdel data i flere ark; Batch Konverter xls, xlsx og PDF...
  • Mere end 300 kraftfulde funktioner. Understøtter Office / Excel 2007-2021 og 365. Understøtter alle sprog. Nem implementering i din virksomhed eller organisation. Fuld funktioner 30-dages gratis prøveperiode. 60 dages pengene tilbage garanti.
kte-fane 201905

Fanen Office bringer en grænseflade til et kontor med Office, og gør dit arbejde meget lettere

  • Aktiver redigering og læsning af faner i Word, Excel, PowerPoint, Publisher, Access, Visio og Project.
  • Åbn og opret flere dokumenter i nye faner i det samme vindue snarere end i nye vinduer.
  • Øger din produktivitet med 50 % og reducerer hundredvis af museklik for dig hver dag!
officetab bund
Sorter kommentarer efter
Kommentarer (20)
Ingen vurderinger endnu. Vær den første til at bedømme!
Denne kommentar blev minimeret af moderatoren på webstedet
tak for vba-koden! Det fungerer perfekt! Vil gerne vide, hvad koden er, hvis jeg skal INDSTÆNKE SOM VÆRDI i stedet for? Thx på forhånd!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Lai Ling,
Følgende kode kan hjælpe dig med at løse problemet. Tak for din kommentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg Som FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbejdsbog
Dim xSheet Som arbejdsark
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Ark1"
xRgStr = "A1:D4"
Indstil xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Med xFileDlg
Hvis .Show = -1 Så
xSelItem = .SelectedItems.Item(1)
Indstil xWorkBook = ThisWorkbook
Indstil xSheet = xWorkBook.Sheets("New Sheet")
Hvis xSheet ikke er noget, så
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Indstil xSheet = xWorkBook.Sheets("New Sheet")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Hvis xFileName = "" Afslut Sub
Gør indtil xFileName = ""
Indstil xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Indstil xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFilnavn = Dir()
xBook.Luk
Loop
End If
Slut med
Indstil xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Sand
xRg.UseStandardWidth = Sand
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, tak for koden. Kan du fortælle mig, hvordan jeg kan inkludere Excel-filnavnet, som dataområdet blev kopieret fra? Dette ville være en stor hjælp!

Tak.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej,

Tak for vejledningen.

Hvordan ville jeg: Kun kopiere rækken i "Sheet1" med værdier fra "total"-rækken og indsætte med [filnavn] i hovedregnearket med navnet "New Sheet". Bemærkning af rækken med Total kan være forskellig i hvert regneark.

For eksempel:
Fil1: Ark1
Col1, Col2, Colx
1,2,15
Resultat,10,50

Fil2: Ark1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Resultat,300,500

MasterFile: "Nyt ark":
fil 1, 10, 50
fil 2, 300, 500
Denne kommentar blev minimeret af moderatoren på webstedet
Hej med jer, det fungerer fint. Er der en måde at ændre til bare at trække over værdierne og ikke formlen?
Tak!!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Trish,
Følgende kode kan hjælpe dig med at løse problemet. Tak for din kommentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg Som FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbejdsbog
Dim xSheet Som arbejdsark
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Ark1"
xRgStr = "A1:D4"
Indstil xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Med xFileDlg
Hvis .Show = -1 Så
xSelItem = .SelectedItems.Item(1)
Indstil xWorkBook = ThisWorkbook
Indstil xSheet = xWorkBook.Sheets("New Sheet")
Hvis xSheet ikke er noget, så
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "New Sheet"
Indstil xSheet = xWorkBook.Sheets("New Sheet")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Hvis xFileName = "" Afslut Sub
Gør indtil xFileName = ""
Indstil xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Indstil xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFilnavn = Dir()
xBook.Luk
Loop
End If
Slut med
Indstil xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Sand
xRg.UseStandardWidth = Sand
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej, det trækker stadig formlerne, ikke værdierne, så det giver mig en #REF-fejl. Jeg ved, at det måske har brug for en .PasteSpecial xlPasteValues ​​et eller andet sted, men jeg kan ikke finde ud af hvor. Kan du hjælpe? Tak!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Tak for dette.


Hvordan inkluderer jeg koden til at gå gennem alle mapper og undermapper og udføre ovenstående kopi?


Tak!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej - Denne kode er perfekt til det, jeg forsøger at opnå.

Er der en måde at gå gennem alle mapper og undermapper og udføre kopieringen?


Tak!
Denne kommentar blev minimeret af moderatoren på webstedet
Hej - Denne kode fungerer meget godt for de første 565 linjer for hver fil, men alle linjer efter overlappes af den næste fil.
er der en måde at løse dette på?
Denne kommentar blev minimeret af moderatoren på webstedet
Tak - hvordan ville man være i stand til at kopiere og indsætte (særlige værdier) fra hvert regneark i en projektmappe til separate ark i en hovedmasterfil?
Denne kommentar blev minimeret af moderatoren på webstedet
hvordan laver man en kode efterlade et tomt felt, hvis cellen er tom?
Denne kommentar blev minimeret af moderatoren på webstedet
for mig ændres fanebladet "Sheet1" for hver af mine filer. For eksempel, Tab1, Tab2, Tab3, Tab4...Hvordan kan jeg konfigurere en løkke til at køre gennem en liste i Excel og blive ved med at ændre "Sheet1"-navnet, indtil det løber gennem alt?
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Nick, VBA-koden nedenfor kan hjælpe dig med at løse problemet. Prøv venligst. Sub LoopThroughFileRename()
'Opdateret af Extendofice 2021/12/31
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg Som FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbejdsbog
Dim xSheet Som arbejdsark
Dim xShs Som Ark
Dim xName Som streng
Dim xFNum Som heltal
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Indstil xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Gør mens xFileName <> ""
Indstil xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Indstil xShs = xWorkBook.Sheets
For xFNum = 1 Til xShs.Count
Indstil xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = Replace(xName, "Sheet""Tab") 'Erstat ark med Tab
xSheet.Name = xName
Næste
xWorkBook.Save
xWorkBook.Close
xFilnavn = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denne kommentar blev minimeret af moderatoren på webstedet
Hej jeg vil have en kode til at kopiere dataene i 6 forskellige projektmapper (i en mappe), som har ark inkluderet i dem til NY WORKBOOK. i vba
plz hjælp mig asp
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Paranusha,
VBA-scriptet i den følgende artikel kan kombinere flere projektmapper eller specificerede ark med projektmapper til en masterprojektmappe. Tjek venligst om det kan hjælpe.
Sådan kombineres flere projektmapper i en hovedprojektmappe i Excel?
Denne kommentar blev minimeret af moderatoren på webstedet
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. Vil du give mig besked om VBA-koden for at automatisere essas imponer? Me ajudaria muito, obrigada.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Maria Soares,
Tjek venligst om VBA-koden i det følgende indlæg kan hjælpe.
Hvordan udskrives flere projektmapper i Excel?
Denne kommentar blev minimeret af moderatoren på webstedet
Mit scenarie er det samme, bortset fra at jeg har flere ark i hver fil, alle med forskellige navne, men konsistente mellem filer. Er der en måde at løkke denne kode for at kopiere dataene i filerne og indsætte (værdier) til specifikke arknavne i masterprojektmappen? Arknavnene i masteren er de samme som i filerne. Jeg vil gå igennem dem. Mængden af ​​data i hvert ark vil også variere, så jeg bliver nødt til at vælge dataene i hvert ark ved at bruge noget som dette:

Range("A1"). Vælg
Range(Udvalg, Valg.End(xlNed)).Vælg
Range(Udvalg, Valg.End(xlTilHøjre)).Vælg


Filarknavne er Giving, Services, Forsikring, Bil, Andre Udgifter osv...

Tak på forhånd.
Denne kommentar blev minimeret af moderatoren på webstedet
Hej Andrew Shahan,
Følgende VBA-kode kan løse dit problem. Efter at have kørt koden og valgt en mappe, vil koden automatisk matche regnearket efter navn og indsætte dataene i regnearket af samme navn i masterprojektmappen.
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
Der er endnu ingen kommentarer her
Efterlad dine kommentarer
Sender som gæst
×
Bedøm dette indlæg:
0   Tegn
Foreslåede steder

Følg os

Copyright © 2009 - www.extendoffice.com. | Alle rettigheder forbeholdes. Drevet af ExtendOffice. | | Sitemap
Microsoft og Office-logoet er varemærker eller registrerede varemærker tilhørende Microsoft Corporation i USA og / eller andre lande.
Beskyttet af Sectigo SSL