Yüzlerce Excel elektronik tablosu dosyasını nasıl birleştirebilirim?

Aynı biçime sahip yüzlerce Excel dosyasına sahibim (örneğin, Excel dosyası başına 4 çalışma sayfası). Tüm dosyaları orijinaller ile aynı formata sahip olması gereken tüm şarkı söyleyen ve dans eden 1 dosyada birleştirmem gerekiyor (yani hepsi aynı adda olan dört ayrı çalışma sayfasını saklayın).

Her dosya aynı şekilde yapılandırılmış olsa da, sayfa 1 ve 2 arasındaki (örneğin) sütun sayısı (ve başlık adları) farklıdır. Bu yüzden tek bir sayfada her şeyle tek bir dosyada birleştirilemez!

İki komplikasyon var:

1. Kaynak dosyayı ("dosya adı") tanımlamak için birleştirilmiş dosyada (EACH sayfasında) bir EKSTRA sütunu oluşturmam gerekiyor.

2. Dosyalar, birleştirilmiş dosyadan kaldırmam gereken çok sayıda sıfır veri girişi (ör. 55 satır yararlı veri ve ardından yüzlerce sıfır sırası) içerir.

VBA'yı hiç kullanmadım, ama herkes sanırım bir yerden başlamalı.

Bu, sahip olduğunuz kudretli bir istek, ancak yakmak için bir akşam geçirdim, işte işe yarayacağını düşündüğüm bazı kodlar. (Sayfalarınızın biçimini bilmemeniz yardımcı olmuyor ancak bu konuda çalışabiliriz.)

Yeni bir çalışma kitabı açın (bu ana çalışma kitabınız olacaktır), VBA ortamına (Alt + F11) gidin ve yeni bir modül oluşturun (Ekle> Modül). Aşağıdaki VBA kodunu yeni modül penceresine yapıştırın:

Option Explicit
Const NUMBER_OF_SHEETS = 4

Public Sub GiantMerge()
    Dim externWorkbookFilepath As Variant
    Dim externWorkbook As Workbook
    Dim i As Long
    Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
    Dim mainCurEnd As Range

    Application.ScreenUpdating = False

    ' Initialise

    ' Correct number of sheets
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
        ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
    ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
        For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
            ThisWorkbook.Sheets(i).Delete
        Next i
    End If
    Application.DisplayAlerts = True

    For i = 1 To NUMBER_OF_SHEETS
        Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
    Next i


    ' Load the data
    For Each externWorkbookFilepath In GetWorkbooks()
        Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)

        For i = 1 To NUMBER_OF_SHEETS

            If mainLastEnd(i).Row > 1 Then
                ' There is data in the sheet

                ' Copy new data (skip headings)
                externWorkbook.Sheets(i).Range("A2:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
            Else
                ' No nata in sheet yet (prob very first run)

                ' Get correct sheet name from first file we check
                ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name

                ' Copy new data (with headings)
                externWorkbook.Sheets(i).Range("A1:" & GetTrueEnd(externWorkbook.Sheets(i)).Address).Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)

                ' Add file name heading
                ThisWorkbook.Sheets(i).Cells(1, mainCurEnd.Column).Value = "File Name"
            End If

            ' Add file name into extra column
            ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

            Set mainLastEnd(i) = mainCurEnd
        Next i

        externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
End Sub

' Returns a collection of file paths, or an empty collection if the user selects cancel
Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
                                               FileFilter:="Excel Files, *.xls;*.xlsx", _
                                               MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
        For Each xlFile In fileNames
            GetWorkbooks.Add xlFile
        Next xlFile
    End If
End Function

' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

        ' look back through the last rows of the table, looking for a non-zero value
        For r = lastRow To 1 Step -1
            For c = 1 To lastCol
                If ws.Cells(r, c).Text <> "" Then
                    If ws.Cells(r, c).Text <> 0 Then
                        Set GetTrueEnd = ws.Cells(r, lastCol)
                        Exit Function
                    End If
                End If
            Next c
        Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
End Function

Sakla, kullanmaya başlamaya hazırız.

Makroyu çalıştır GiantMerge. Birleştirmek istediğiniz excel dosyalarını seçmek zorundasınız (diyalog kutusuyla birden fazla dosyayı, normal pencereler yolunda seçebilirsiniz (birden fazla bireysel dosya seçmek için Ctrl, bir dosya aralığı seçmek için Shift)). Makroyu birleştirmek istediğiniz tüm dosyalar üzerinde çalıştırmak zorunda değilsiniz, aynı anda birkaç defa yapabilirsiniz. İlk çalıştırdığınızda, ana çalışma kitabınızı doğru sayıda sayfaya sahip olacak şekilde yapılandırır, birleştirmek için seçtiğiniz ilk çalışma kitabına göre sayfaları adlandırır ve başlıklara ekler.

Aşağıdaki varsayımları yaptım (tam bir liste değil):

• 4 sayfa vardır (Bu kodun üstündeki sabiti değiştirerek kolayca değiştirilebilir.)
• Tüm ekstra çalışma kitaplarında sayfalar aynı sıradadır
• Her sayfadaki sütunlar tüm çalışma kitaplarında aynı sıradadır (çalışma kitabındaki tüm sayfaların aynı sütunlara sahip olmamasına rağmen. Örneğin, Çalışma Kitabı1, Sayfa1'de A, B, C, Sayfa2'de sütunlar A, B; Çalışma Kitabı2, Sayfa1'de bulunur. A, B, C, Sayfa2'de A, B sütunları vardır. Etc. Bir çalışma kitabında aşağıdakiler varsa: Sayfa1'de A, C, B, Sayfa2'de B, A sütunları vardır, sonra sütunlar doğru şekilde hizalanmaz)
• Ek çalışma kitaplarında fazladan veya eksik sütun yok
• Her çalışma kitabındaki her sayfada bir başlık satırı vardır (ve yalnızca her sayfada ilk satırdadır)
• Tüm sütunlar dahil edilmelidir (yalnızca 0 içermeli olsalar bile)
• Yalnızca 0 içeren bir tablonun sonundaki tüm satırlar master’a kopyalanmaz
• Ek sütunda ihtiyacınız olan sadece dosya adıdır (dosya yolu değil)
• Bazı sayfalarda herhangi bir veri yoksa (veya sadece sıfırlarla dolu) ne kadar işe yarayacağını bilmiyorum.

Bu yardımcı olur umarım.

Ron de Bruin'in RDBMerge adlı Excel çalışma sayfalarını birleştirmek için harika bir Windows eklentisi oluşturduğunu da belirtmek gerekir. Talimatlar burada bulunabilir: http://www.rondebruin.nl/merge.htm . Excel 2007'de xlsx dosyalarını birleştirmek benim için kusursuz çalıştı.

Kaynak dosya adını içeren birleştirilmiş dosyada fazladan bir sütun oluşturur. Yine de sıfır veri girişini (orijinal sorunun ikinci kısmı) nasıl kullandığından emin değilim.

Yalnızca bu excel dosyalarını birleştirmek için bir araca ihtiyacınız varsa, JMC Excel'i inceleyin .

Bu iyi bir büyüklük projesi ama çok yapılabilir. İşte, inşa edebileceğiniz VBA'da iyi bir başlangıç. Bu, (tek başına) bir klasörde varsa birleştirmeniz gereken tüm dosyaları gözden geçirmenize olanak sağlar. Birleştirdiğiniz ana çalışma kitabı bu dizinde olmamalıdır.

Option Explicit
Sub giantmerge()
    Dim f As Object, fso As Object
    Dim folder As String
    Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
    Dim sn1 As String, sn2 As String, sn3 As String, sn4 As String
    Set wb = ThisWorkbook
    'Change sheet names to match those in your workbooks.
    sn1 = "Sheet1"
    sn2 = "Sheet2"
    sn3 = "Sheet3"
    sn4 = "Sheet4"
    Set ws1 = wb.Sheets(sn1)
    Set ws2 = wb.Sheets(sn2)
    Set ws3 = wb.Sheets(sn3)
    Set ws4 = wb.Sheets(sn4)

    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Cancel Selected"
            End
        End If
        folder = .SelectedItems(1)
    End With
    For Each f In fso.GetFolder(folder).Files
        Workbooks.Open Filename:=f.Path
        'Get data and store in temporary arrays.
        Workbooks(f.Name).Close
        'Input data in this workbook (master).
    Next
End Sub

Artık siz (veya başka biri) sonunda For döngüsü için kod sağlayabilirsiniz. Bu yardımcı olur umarım.

Sub simpleXlsMerger()
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    ' change folder path of excel files here
    Set dirObj = mergeObj.Getfolder("D:\change\to\excel\files\path\here")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        ' change "A2" with cell reference of start point for every files here
        ' for example "B3:IV" to merge all files start from columns B and rows 3 
        ' If you're files using more than IV column, change it to the latest column
        ' Also change "A" column on "A65536" to the same column as start point
        Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate

        ' Do not change the following column. It's not the same column as above
        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

Basit bir python betiği kullanarak yöntem (VB'den çok daha kısa!).

https://superuser.com/a/1138948/141182