Sub 拆分為工作薄() Dim wb As Workbook Dim arr As Variant Dim k, m As Integer Dim d As Object Dim brr() Set d = CreateObject("Scripting.Dictionary") With Sheet1 arr = .Range("a1").CurrentRegion End With For k = 2 To UBound(arr) d(arr(k, 1)) = "" Next k For Each s In d.keys Erase brr() n = 1 ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) Set wb = Workbooks.Add For m = 2 To UBound(arr) If arr(m, 1) = s Then brr(n, 1) = arr(m, 1): brr(n, 2) = arr(m, 2) brr(n, 3) = arr(m, 3): brr(n, 4) = arr(m, 4) brr(n, 5) = arr(m, 5): brr(n, 6) = arr(m, 6) brr(n, 7) = arr(m, 7): brr(n, 8) = arr(m, 8) brr(n, 9) = arr(m, 9): brr(n, 10) = arr(m, 10) brr(n, 11) = arr(m, 11): brr(n, 12) = arr(m, 12) brr(n, 13) = arr(m, 13): brr(n, 14) = arr(m, 14) brr(n, 15) = arr(m, 15) n = n + 1 End If Next m ThisWorkbook.Worksheets(1).Rows("1:1").Copy wb.Worksheets(1).Cells(1, 1) wb.Worksheets(1).Columns(1).Cells(wb.Worksheets(1).Columns(1).Cells.Count).End(xlUp).Offset(1).Resize(UBound(brr), UBound(brr, 2)) = brr ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\客戶" & s & ".xls" ActiveWorkbook.Close True Next End Sub
這個公式肯定是做不到了,只能是寫VBA,但是要根據你的表格來定製的,根據你不同的欄位來拆分,所以這個問題,你需要再細化一下,然這些如果不知道什麼是vba呢就是下面這些東西
這些東西看著很難,但實際上對於普通使用者來講,你不用去管他到底是怎樣寫的,你只要會用就行了
Sub 拆分為工作薄() Dim wb As Workbook Dim arr As Variant Dim k, m As Integer Dim d As Object Dim brr() Set d = CreateObject("Scripting.Dictionary") With Sheet1 arr = .Range("a1").CurrentRegion End With For k = 2 To UBound(arr) d(arr(k, 1)) = "" Next k For Each s In d.keys Erase brr() n = 1 ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) Set wb = Workbooks.Add For m = 2 To UBound(arr) If arr(m, 1) = s Then brr(n, 1) = arr(m, 1): brr(n, 2) = arr(m, 2) brr(n, 3) = arr(m, 3): brr(n, 4) = arr(m, 4) brr(n, 5) = arr(m, 5): brr(n, 6) = arr(m, 6) brr(n, 7) = arr(m, 7): brr(n, 8) = arr(m, 8) brr(n, 9) = arr(m, 9): brr(n, 10) = arr(m, 10) brr(n, 11) = arr(m, 11): brr(n, 12) = arr(m, 12) brr(n, 13) = arr(m, 13): brr(n, 14) = arr(m, 14) brr(n, 15) = arr(m, 15) n = n + 1 End If Next m ThisWorkbook.Worksheets(1).Rows("1:1").Copy wb.Worksheets(1).Cells(1, 1) wb.Worksheets(1).Columns(1).Cells(wb.Worksheets(1).Columns(1).Cells.Count).End(xlUp).Offset(1).Resize(UBound(brr), UBound(brr, 2)) = brr ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\客戶" & s & ".xls" ActiveWorkbook.Close True Next End Sub