Private Sub CommandButton1_Click() Dim arr arr = Range("A1:C" & [a65536].End(3).Row) Dim i As Long, wName As String, wPath As String wName = "分類彙總" & Format(Now(), "hhmmss") Dim dc As Object, wb As Workbook, n As Long Set dc = CreateObject("Scripting.dictionary") wPath = ThisWorkbook.Path & "" & wName MkDir wPath For i = 2 To UBound(arr) If Not dc.exists(arr(i, 1)) Then Set wb = Workbooks.Add wb.SaveAs wPath & "" & arr(i, 1) & ".xls" "001 wb.Sheets(1).Name = arr(i, 1) "填寫表頭 wb.Sheets(1).[a1] = arr(1, 1) wb.Sheets(1).[b1] = arr(1, 2) wb.Sheets(1).[c1] = arr(1, 3) dc.Add arr(i, 1), "" End If With Workbooks(arr(i, 1) & ".xls").Sheets(1) "002 n = .[a65536].End(3).Row + 1 .Cells(n, 1) = arr(i, 1) .Cells(n, 2) = arr(i, 2) .Cells(n, 3) = arr(i, 3) End With Next Dim ar ar = dc.keys For i = 0 To UBound(ar) Workbooks(ar(i) & ".xls").Close True "003 Next End Sub
程式碼如下：
如果你是2003以上版本的Excel，那麼請將上面三個地方的.xls更換成.xlsx
詳細可下載附件測試，新檔案在新建的以時間命名的“分類彙總”資料夾內。
Private Sub CommandButton1_Click() Dim arr arr = Range("A1:C" & [a65536].End(3).Row) Dim i As Long, wName As String, wPath As String wName = "分類彙總" & Format(Now(), "hhmmss") Dim dc As Object, wb As Workbook, n As Long Set dc = CreateObject("Scripting.dictionary") wPath = ThisWorkbook.Path & "" & wName MkDir wPath For i = 2 To UBound(arr) If Not dc.exists(arr(i, 1)) Then Set wb = Workbooks.Add wb.SaveAs wPath & "" & arr(i, 1) & ".xls" "001 wb.Sheets(1).Name = arr(i, 1) "填寫表頭 wb.Sheets(1).[a1] = arr(1, 1) wb.Sheets(1).[b1] = arr(1, 2) wb.Sheets(1).[c1] = arr(1, 3) dc.Add arr(i, 1), "" End If With Workbooks(arr(i, 1) & ".xls").Sheets(1) "002 n = .[a65536].End(3).Row + 1 .Cells(n, 1) = arr(i, 1) .Cells(n, 2) = arr(i, 2) .Cells(n, 3) = arr(i, 3) End With Next Dim ar ar = dc.keys For i = 0 To UBound(ar) Workbooks(ar(i) & ".xls").Close True "003 Next End Sub