Sub 分拆工作表()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set d = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 4).End(xlUp).Row
arr = .Range("c1:c" & r)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = .Cells(1, 1).Resize(1, 69)
End If
Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 69))
Next
End With
For Each aa In d.keys
Set wb = Workbooks.Add
With wb
With .Worksheets("sheet1")
.Name = aa
d(aa).Copy .Range("a1")
End With
.SaveAs Filename:=ThisWorkbook.Path & "\" & aa & ".xlsx"
.Close False
End With
Next
End Sub
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set d = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 4).End(xlUp).Row
arr = .Range("c1:c" & r)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = .Cells(1, 1).Resize(1, 69)
End If
Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 69))
Next
End With
For Each aa In d.keys
Set wb = Workbooks.Add
With wb
With .Worksheets("sheet1")
.Name = aa
d(aa).Copy .Range("a1")
End With
.SaveAs Filename:=ThisWorkbook.Path & "\" & aa & ".xlsx"
.Close False
End With
Next
End Sub