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

Hur går man igenom filer i en katalog och kopierar data till ett huvudark i Excel?

Antag att det finns flera Excel-arbetsböcker i en mapp, och du vill slinga igenom alla dessa Excel-filer och kopiera data från angivet intervall med samma namn-kalkylblad till ett huvudark i Excel, vad kan du göra? Denna artikel introducerar en metod för att uppnå det i detalj.

Sök igenom filer i en katalog och kopiera data till ett huvudark med VBA-kod


Sök igenom filer i en katalog och kopiera data till ett huvudark med VBA-kod

Om du vill kopiera specificerad data i intervall A1: D4 från alla ark1 av arbetsböcker i en viss mapp till ett huvudark, gör så här.

1. I arbetsboken skapar du ett huvudark, tryck på andra + F11 nycklar för att öppna Microsoft Visual Basic för applikationer fönster.

2. I Microsoft Visual Basic för applikationer fönstret klickar Insert > Modulerna. Kopiera sedan VBA-koden nedan till kodfönstret.

VBA-kod: slinga igenom filer i en mapp och kopiera data till ett huvudark

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

Anmärkningar:

1). I koden, “A1: D4"Och"Sheet1”Betyder att data i intervall A1: D4 för hela ark 1 kommer att kopieras till huvudarket. Och “Nytt blad”Är namnet på det nya skapade huvudarket.
2). Excel-filerna i den specifika mappen ska inte öppnas.

3. tryck på F5 för att köra koden.

4. I öppningen Bläddra välj mappen som innehåller filerna du kommer att gå igenom och klicka sedan på OK knapp. Se skärmdump:

Sedan skapas ett huvudkalkylblad med namnet "Nytt ark" i slutet av den nuvarande arbetsboken. Och data i intervall A1: D4 för alla ark 1 i vald mapp listas inuti kalkylbladet.


Relaterade artiklar:


De bästa Office-produktivitetsverktygen

Kutools för Excel löser de flesta av dina problem och ökar din produktivitet med 80%

  • återanvändning: Sätt snabbt i komplexa formler, diagram och allt som du har använt tidigare; Kryptera celler med lösenord; Skapa e-postlista och skicka e-post ...
  • Super Formula Bar (enkelt redigera flera rader med text och formel); Läslayout (enkelt läsa och redigera ett stort antal celler); Klistra in i filtrerat intervall...
  • Sammanfoga celler / rader / kolumner utan att förlora data; Delat cellinnehåll; Kombinera duplicerade rader / kolumner... Förhindra duplicerade celler; Jämför intervall...
  • Välj Duplicera eller Unikt Rader; Välj tomma rader (alla celler är tomma); Super Find och Fuzzy Find i många arbetsböcker; Slumpmässigt val ...
  • Exakt kopia Flera celler utan att ändra formelreferens; Skapa referenser automatiskt till flera ark; Sätt in kulor, Kryssrutor och mer ...
  • Extrahera text, Lägg till text, ta bort efter position, Ta bort mellanslag; Skapa och skriva ut personsökningstalsatser; Konvertera mellan celler innehåll och kommentarer...
  • Superfilter (spara och tillämpa filterscheman på andra ark); Avancerad sortering efter månad / vecka / dag, frekvens och mer; Specialfilter av fet, kursiv ...
  • Kombinera arbetsböcker och arbetsblad; Sammanfoga tabeller baserat på nyckelkolumner; Dela data i flera ark; Batchkonvertera xls, xlsx och PDF...
  • Mer än 300 kraftfulla funktioner. Stöder Office / Excel 2007-2021 och 365. Stöder alla språk. Enkel implementering i ditt företag eller organisation. Fullständiga funktioner 30 dagars gratis provperiod. 60 dagars pengarna tillbaka-garanti.
kte-flik 201905

Fliken Office ger ett flikgränssnitt till Office och gör ditt arbete mycket enklare

  • Aktivera flikredigering och läsning i Word, Excel, PowerPoint, Publisher, Access, Visio och Project.
  • Öppna och skapa flera dokument i nya flikar i samma fönster, snarare än i nya fönster.
  • Ökar din produktivitet med 50 % och minskar hundratals musklick för dig varje dag!
officetab botten
Sortera kommentarer efter
Kommentarer (20)
Inga betyg än. Bli först med att betygsätta!
Denna kommentar minimerades av moderatoren på webbplatsen
tack för vba-koden! Det fungerar perfekt! Skulle vilja veta vad koden är om jag behöver KLISTRA SOM VÄRDE istället? Thx i förväg!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Lai Ling,
Följande kod kan hjälpa dig att lösa problemet. Tack för din kommentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbetsbok
Dim xSheet Som arbetsblad
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Ställ in xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Med xFileDlg
Om .Show = -1 Då
xSelItem = .SelectedItems.Item(1)
Ställ in xWorkBook = ThisWorkbook
Ställ in xSheet = xWorkBook.Sheets("Nytt ark")
Om xSheet är ingenting då
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Namn = "Nytt ark"
Ställ in xSheet = xWorkBook.Sheets("Nytt ark")
End If
xFilnamn = Dir(xSelItem & "\*.xlsx", vbNormal)
Om xFileName = "" Avsluta Sub
Gör tills xFileName = ""
Ställ in xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ställ in xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFilnamn = Dir()
xBook.Stäng
loop
End If
Sluta med
Ställ in xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Sant
xRg.UseStandardWidth = Sant
Application.DisplayAlerts = Sant
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, tack för koden. Kan du berätta för mig hur jag kan inkludera Excel-filnamnet från vilket dataintervallet kopierades? Detta skulle vara till stor hjälp!

Tack.
Denna kommentar minimerades av moderatoren på webbplatsen
Hallå,

Tack för handledningen.

Hur skulle jag: Kopiera bara raden i "Sheet1" med värden från "total"-raden och klistra in med [filnamn] i huvudarbetsbladet med namnet "New Sheet". Att notera raden med Total kan vara olika i varje kalkylblad.

Till exempel:
Fil1: Blad1
Kol1, Kol2, Colx
1,2,15
Resultat,10,50

Fil2: Blad1
Kol1, Kol2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Resultat,300,500

MasterFile: "Nytt ark":
fil 1, 10, 50
fil 2, 300, 500
Denna kommentar minimerades av moderatoren på webbplatsen
Hej på er, det här fungerar utmärkt. Finns det något sätt att ändra till att bara dra över värdena och inte formeln?
Tack!!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Trish,
Följande kod kan hjälpa dig att lösa problemet. Tack för din kommentar.

Sub Merge2MultiSheets()
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbetsbok
Dim xSheet Som arbetsblad
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Sheet1"
xRgStr = "A1:D4"
Ställ in xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Med xFileDlg
Om .Show = -1 Då
xSelItem = .SelectedItems.Item(1)
Ställ in xWorkBook = ThisWorkbook
Ställ in xSheet = xWorkBook.Sheets("Nytt ark")
Om xSheet är ingenting då
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Namn = "Nytt ark"
Ställ in xSheet = xWorkBook.Sheets("Nytt ark")
End If
xFilnamn = Dir(xSelItem & "\*.xlsx", vbNormal)
Om xFileName = "" Avsluta Sub
Gör tills xFileName = ""
Ställ in xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ställ in xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xFilnamn = Dir()
xBook.Stäng
loop
End If
Sluta med
Ställ in xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Sant
xRg.UseStandardWidth = Sant
Application.DisplayAlerts = Sant
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, det drar fortfarande formlerna, inte värdena, så det ger mig ett #REF-fel. Jag vet att det kan behöva en .PasteSpecial xlPasteValues ​​någonstans, men jag kan inte ta reda på var. Kan du hjälpa? Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Tack för detta.


Hur inkluderar jag koden för att gå igenom alla mappar och undermappar och utföra ovanstående kopiering?


Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej - Den här koden är perfekt för det jag försöker uppnå.

Finns det något sätt att gå igenom alla mappar och undermappar och utföra kopieringen?


Tack!
Denna kommentar minimerades av moderatoren på webbplatsen
Hej - Den här koden fungerar mycket bra för de första 565 raderna för varje fil, men alla rader efter överlappas av nästa fil.
finns det något sätt att fixa detta?
Denna kommentar minimerades av moderatoren på webbplatsen
Tack - hur skulle man kunna kopiera och klistra in (speciella värden) från varje kalkylblad i en arbetsbok till separata ark i en huvudfil?
Denna kommentar minimerades av moderatoren på webbplatsen
hur gör man till kod lämnar en tom om cellen är tom?
Denna kommentar minimerades av moderatoren på webbplatsen
för mig ändras namnet på fliken "Sheet1" för var och en av mina filer. Till exempel, Tab1, Tab2, Tab3, Tab4...Hur kan jag ställa in en loop för att köra igenom en lista i Excel och fortsätta att ändra "Sheet1"-namnet tills den går igenom allt?
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Nick, VBA-koden nedan kan hjälpa dig att lösa problemet. Gör ett försök. Sub LoopThroughFileRename()
'Uppdaterad av Extendofice 2021/12/31
Dim xRg As Range
Dim xSelItem som variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook Som arbetsbok
Dim xSheet Som arbetsblad
Dim xShs As Sheets
Dim xName As String
Dim xFNum Som heltal
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Ställ in xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFilnamn = Dir(xSelItem & "\*.xlsx", vbNormal)
Gör medan xFileName <> ""
Ställ in xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Ställ in xShs = xWorkBook.Sheets
För xFNum = 1 Till xShs.Count
Ställ in xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = Replace(xName, "ark""Fliken") 'Ersätt ark med Tab
xSheet.Name = xName
Nästa
xWorkBook.Save
xWorkBook.Stäng
xFilnamn = Dir()
loop
Application.DisplayAlerts = Sant
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Denna kommentar minimerades av moderatoren på webbplatsen
Hej, jag vill ha en kod för att kopiera data i 6 olika arbetsböcker (i en mapp) som har ark inkluderade i dem till NY ARBETSBOK. i vba
snälla hjälp mig asp
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Paranusha,
VBA-skriptet i följande artikel kan kombinera flera arbetsböcker eller specificerade ark med arbetsböcker till en huvudarbetsbok. Kontrollera om det kan hjälpa.
Hur man kombinerar flera arbetsböcker till en huvudarbetsbok i Excel?
Denna kommentar minimerades av moderatoren på webbplatsen
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. Skicka mig enviar om códgo de VBA que automatize essas imponões? Me ajudaria muito, obrigada.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Maria Soares,
Kontrollera om VBA-koden i följande inlägg kan hjälpa.
Hur skriver jag ut flera arbetsböcker i Excel?
Denna kommentar minimerades av moderatoren på webbplatsen
Mitt scenario är liknande, förutom att jag har flera ark i varje fil, alla med olika namn men konsekventa mellan filer. Finns det något sätt att loopa den här koden för att kopiera data i filerna och klistra in (värden) till specifika arknamn i huvudarbetsboken? Arknamnen i mastern är desamma som i filerna. Jag vill gå igenom dem. Dessutom kommer mängden data i varje blad att variera, så jag måste välja data i varje blad med något så här:

Range("A1"). Välj
Range(Selection, Selection.End(xlDown)).Välj
Range(Selection, Selection.End(xlToRight)).Välj


Filbladsnamn är Giving, Services, Försäkring, Bil, Andra Utgifter, etc...

Tack på förhand.
Denna kommentar minimerades av moderatoren på webbplatsen
Hej Andrew Shahan,
Följande VBA-kod kan lösa ditt problem. Efter att ha kört koden och valt en mapp kommer koden automatiskt att matcha kalkylbladet efter namn och klistra in data i kalkylbladet med samma namn i huvudarbetsboken.
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
Det finns inga kommentarer här ännu
Lämna dina kommentarer
Postar som gäst
×
Betygsätt detta inlägg:
0   Tecken
Föreslagna platser

Följ oss

Copyright © 2009 - www.extendoffice.com. | Alla rättigheter förbehållna. Drivs av ExtendOffice. | | Sitemap
Microsoft och Office-logotypen är varumärken eller registrerade varumärken som tillhör Microsoft Corporation i USA och / eller andra länder.
Skyddad av Sectigo SSL