Excel·VBA模闆生成檔案

不同于《python實作Excel郵件合并》，字元串内容替換生成檔案，僅複制整行資料插入模闆中生成工作表，單獨儲存為工作簿，但如果存在同名工作簿檔案，則将工作表附加在該工作簿中

Sub 模闆生成工作薄()
    Application.Visible = False  '背景運作，不顯示界面
    Application.DisplayAlerts = False  '不顯示警告資訊
    Dim arr, i, k, v, dict As Object, d As Object, fso As Object
    Set dict = CreateObject("scripting.dictionary")
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("Scripting.FileSystemObject")  '檔案通路對象
    
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        Set temp = Range(Cells(i, 1), Cells(i, UBound(arr, 2)))  '資料區域range
        If Not dict.Exists(arr(i, 2)) Then  '新鍵-值
            Set dict(arr(i, 2)) = temp
        Else  '已有鍵-值，更新
            Set dict(arr(i, 2)) = Union(dict(arr(i, 2)), temp)  'Union,range對象
        End If
        d(arr(i, 2)) = d(arr(i, 2)) + 1  '行數
    Next
    k = dict.keys
    v = dict.Items
    Set mb = Sheets("模闆")
    save_path = ThisWorkbook.Path  '檔案儲存路徑
    For i = 0 To dict.Count - 1:   '周遊字典，建立、寫入wb
        mb.Copy After:=Sheets(Sheets.Count)  '複制模闆工作表
        Set ws = Application.ActiveSheet
            ws.Name = "9月"
            ws.Rows(4).Resize(d(k(i))).Insert
            v(i).Copy ws.Range("a4")
            Range("x" & d(k(i)) + 4) = "=sum(x4:x" & d(k(i)) + 3 & ")"
            Range("z" & d(k(i)) + 4) = "=sum(z4:z" & d(k(i)) + 3 & ")"
            Range("aa" & d(k(i)) + 4) = "=sum(aa4:aa" & d(k(i)) + 3 & ")"
        save_file = save_path + "\" + k(i) + ".xlsx"  '儲存檔案路徑全名
        If fso.FileExists(save_file) Then  '檔案是否存在
            Set wb = Application.Workbooks.Open(save_file)  '打開檔案
            ws.Copy After:=Sheets(wb.Sheets.Count)
        Else
            ws.Copy
            Set wb = ActiveWorkbook  '建立新工作簿
        End If
        ws.Delete
        wb.SaveAs Filename:=save_file
        wb.Close (False)
    Next
    Application.Visible = True
    Application.DisplayAlerts = True
            
End Sub
           

附件

《Excel·VBA模闆生成檔案（附件）》