Jak mogę scalić setki plików arkusza kalkulacyjnego Excel?

Mam setki plików Excela w tym samym formacie (tj. 4 arkusze na plik Excela). Muszę połączyć wszystkie pliki w jeden cały plik śpiewu i tańca, który musi mieć ten sam format, co oryginały (tj. Zachować cztery oddzielne arkusze, z których wszystkie są identycznie nazwane).

Podczas gdy każdy plik ma taką samą strukturę, liczba kolumn (i nazw nagłówków) między arkuszem 1 i 2 (na przykład) jest inna. Więc nie można go połączyć w jeden plik ze wszystkim w jednym arkuszu!

Istnieją dwie komplikacje:

1. Muszę utworzyć kolumnę EXTRA w scalonym pliku (na arkuszu KAŻDY), aby zidentyfikować plik źródłowy („nazwa pliku”).

2. Pliki zawierają wiele zerowych wpisów danych (np. 55 wierszy przydatnych danych, po których następują setki wierszy zer), które muszę usunąć z scalonego pliku.

Nigdy nie używałem VBA, ale każdy musi zacząć gdzieś, jak przypuszczam.

To potężna prośba, ale miałem wieczór na spalenie, więc oto kod, który według mnie zadziała. (Nieznajomość formatów arkuszy nie pomaga, ale możemy z tego pracować.)

Otwórz nowy skoroszyt (będzie to Twój główny skoroszyt), przejdź do środowiska VBA (Alt + F11) i utwórz nowy moduł (Wstaw> Moduł). Wklej następujący kod VBA do nowego okna modułu:

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

Zapisz go i jesteśmy gotowi, aby zacząć go używać.

Uruchom makro GiantMerge. Musisz wybrać pliki Excela, które chcesz scalić (możesz zaznaczyć wiele plików za pomocą okna dialogowego, w zwykły sposób Windows (Ctrl, aby zaznaczyć wiele pojedynczych plików, Shift, aby wybrać zakres plików)). Nie musisz uruchamiać makra na wszystkich plikach, które chcesz scalić, możesz to zrobić tylko kilka razy. Po pierwszym uruchomieniu skonfiguruje on główny skoroszyt, aby mieć prawidłową liczbę arkuszy, nazywać arkusze na podstawie pierwszego skoroszytu wybranego do scalenia i dodawać do nagłówków.

Założyłem następujące założenia (nie pełna lista):

• Dostępne są 4 arkusze (można to łatwo zmienić, zmieniając stałą na górze kodu).
• Arkusze są w tej samej kolejności we wszystkich dodatkowych skoroszytach
• Kolumny w każdym arkuszu są w tej samej kolejności we wszystkich skoroszytach (choć nie wszystkie arkusze w książce roboczej będą miały takie same kolumny. Np. WorkBook1, Arkusz1 ma kolumny A, B, C, Arkusz2 ma kolumny A, B; WorkBook2, Arkusz1 ma kolumny A, B, C, Arkusz2 ma kolumny A, B. itd. Jeśli skoroszyt ma następujące elementy: Arkusz1 ma kolumny A, C, B, Arkusz2 ma kolumny B, A, a następnie kolumny nie będą poprawnie wyrównane)
• W dodatkowych skoroszytach nie ma żadnych dodatkowych lub brakujących kolumn
• W każdym ze skoroszytów znajduje się wiersz nagłówka (i znajduje się on w pierwszym wierszu tylko na każdym arkuszu)
• Wszystkie kolumny powinny być uwzględnione (nawet jeśli zawierają tylko 0)
• Wszystkie wiersze na końcu tabeli zawierającej tylko 0 nie są kopiowane do wzorca
• Jest to tylko nazwa pliku (a nie ścieżka pliku) potrzebna w dodatkowej kolumnie
• Nie wiem, jak dobrze będzie działać, jeśli w niektórych arkuszach nie ma żadnych danych (lub są one po prostu wypełnione zerami)

Mam nadzieję że to pomoże.

Warto również wspomnieć, że Ron de Bruin stworzył fantastyczną wtyczkę Windows do łączenia arkuszy programu Excel o nazwie RDBMerge. Instrukcje można znaleźć tutaj: http://www.rondebruin.nl/merge.htm . To działało bez zarzutu, łącząc pliki xlsx w programie Excel 2007.

Tworzy dodatkową kolumnę w scalonym pliku zawierającą nazwę pliku źródłowego. Nie wiem jednak, jak obsługuje zerowe wpisy danych (druga część oryginalnego pytania).

Jeśli potrzebujesz narzędzia do scalenia tych plików Excela, sprawdź JMC Excel .

To projekt o przyzwoitej wielkości, ale bardzo wykonalny. Oto dobry początek VBA, na którym możesz budować. Pozwoli ci to przejrzeć wszystkie pliki, które musisz scalić, jeśli masz je (same) w jednym folderze. Skoroszyt główny, do którego się dołączasz, NIE powinien znajdować się w tym katalogu.

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

Teraz ty (lub ktoś inny) może dostarczyć kod pętli For na końcu. Mam nadzieję że to pomoże.

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

Metoda wykorzystująca prosty skrypt Pythona (znacznie krótszy niż VB!).

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