|
Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set ww = ThisWorkbook
lj = ThisWorkbook.Path & "\拆分文件\"
For Each sh In Sheets
mc = sh.Name
r = sh.Cells(Rows.Count, 1).End(xlUp).Row
y = sh.Cells(3, Columns.Count).End(xlToLeft).Column
ar = sh.Range(sh.Cells(1, 1), sh.Cells(r, y))
For i = 5 To UBound(ar)
If ar(i, 2) <> "" Then
If Not d.exists(ar(i, 2)) Then Set d(ar(i, 2)) = CreateObject("scripting.dictionary") ''乡镇
If Not d(ar(i, 2)).exists(mc) Then Set d(ar(i, 2))(mc) = CreateObject("scripting.dictionary") ''乡镇和工作表名称
d(ar(i, 2))(mc)(i) = i '''对应的数据行
End If
Next i
Next sh
For Each k In d.keys ''循环乡镇
m = 0
For Each kk In d(k).keys ''循环工作表
m = m + 1
If m = 1 Then
ww.Sheets(kk).Copy
Set wb = ActiveWorkbook
Else
ww.Sheets(kk).Copy after:=wb.Worksheets(wb.Worksheets.Count)
End If
With ww.Sheets(kk)
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(3, Columns.Count).End(xlToLeft).Column
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
With wb.ActiveSheet
.UsedRange.Offset(4).Borders.LineStyle = 0
.UsedRange.Offset(4) = Empty
For Each wk In d(k)(kk).keys ''循环乡镇下的工作表的所有行
n = n + 1
br(n, 1) = n
For j = 2 To UBound(ar, 2)
br(n, j) = ar(wk, j)
Next j
Next wk
.[a5].Resize(n, UBound(br, 2)) = br
.[a5].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
For Each shp In .Shapes
shp.Delete
Next shp
End With
Next kk
wb.SaveAs Filename:=lj & k & ".xlsx"
wb.Close
Next k
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|