要求

有個excel檔案，把檔案中的資料按照某列，將相同的資料存為一個excel檔案。

VBA程式碼

執行下面的程式碼後，會在該excel的同級目錄下建立一個新資料夾“拆分出的表格”，拆分後生成的新檔案會存在這個目錄下。

我拆分了30個檔案，大約一分鐘時間。請耐心等待。
如果你感覺沒有進度，你可以看一下同級目錄下“拆分出的表格”資料夾中是否在緩慢生成新的檔案。

Sub 拆分成多個檔案()

    '輸入使用者想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("請輸入拆分工作表的名稱：")
    Worksheets(sheet_name).Select
 


    '輸入獲取拆分需要的條件列
    Dim col_name
    col_name = Application.InputBox("請輸入拆分依據的列號(如A):")

    '輸入拆分的開始行，要求輸入的是數字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="請輸入拆分的開始行:", Type:=1)

    '暫停螢幕更新
    Application.ScreenUpdating = False

    '工作表的總行數
    Dim end_row
    end_row = Worksheets(sheet_name).Range("A65536"
 
).End(xlUp).Row

    '遍歷計算所有拆分表，每個拆分表的格式為"表名稱,錶行數"
    '對於二維陣列，ReDim只能擴充最後一維，因此sheet_map行不變，擴充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0

    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
 

        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With

    '根據前面計算的拆分表，拆分成單個檔案
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '建立最終資料資料夾
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '建立新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xls"
        ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
        ActiveSheet.Name = sheet_map(0, i)
        '啟用當前工作簿，ThisWorkbook表示當前跑程式碼的工作簿
        ThisWorkbook.Activate

        '拷貝條目資料(即最前面不需要拆分的資料行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
        '拷貝拆分表的專屬資料
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)

        '儲存檔案
        Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
    Next

    '進行螢幕更新
    Application.ScreenUpdating = True

    MsgBox "拆分工作表完成"

End Sub

遇到的小問題

巨集被禁用