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

Anta att du har flera Excel-arbetsböcker i en mapp och behöver gå igenom alla dessa filer för att kopiera data från ett specifikt område i ett konsekvent kalkylblad (t.ex. Sheet1) till ett huvudkalkylblad. Den här guiden ger en detaljerad VBA-lösning för att effektivisera denna process i Excel.

Gå igenom arbetsböcker 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 data från intervallet A1:D4 i alla Kalkylblad 1 i arbetsböcker i en specifik mapp och klistra in dem i 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:

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:

Ett huvudkalkylblad med namnet "Nytt ark" skapas sedan i slutet av den aktuella arbetsboken. Och data i området A1:D4 för alla Blad1 i den valda mappen listas i kalkylbladet.

Relaterade artiklar:

• Hur kopierar man celldata med radhöjd och kolumnbredd i Excel?