|
Sub 批量拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set sh = ThisWorkbook.Worksheets("模板")
lj = ThisWorkbook.Path & "\生产单\"
tt = Timer
With ThisWorkbook.Worksheets("总表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 4).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
For i = 2 To UBound(arr)
If arr(i, 3) <> "" Then
If IsDate(arr(i, 3)) Then
nf = Year(arr(i, 3))
yf = Month(arr(i, 3))
dc(nf & "|" & yf) = ""
End If
End If
Next i
For Each kc In dc.keys
rr = Split(kc, "|")
ny = rr(0)
yf = rr(1)
wjj_1 = lj & nf & "年"
wjj_2 = lj & nf & "年\" & yf & "月"
If Not fso.folderexists(wjj_1) Then fso.CreateFolder wjj_1
If Not fso.folderexists(wjj_2) Then fso.CreateFolder wjj_2
Next kc
For i = 2 To UBound(arr)
If arr(i, 1) <> "" Then
If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
d(arr(i, 1))(arr(i, 7)) = i
End If
Next i
rr = Array([b3].Address, [e3].Address, [h3].Address, [b4].Address, [e4].Address, [h4].Address, [b5].Address, [e5].Address, [h5].Address, [c6].Address, [c7].Address, [c8].Address, [h8].Address)
For Each k In d.keys
m = 0
For Each kk In d(k).keys
xh = d(k)(kk)
nf = Year(arr(xh, 3))
yf = Month(arr(xh, 3))
m = m + 1
If m = 1 Then
sh.Copy
Set wb = ActiveWorkbook
ElseIf m > 1 Then
sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
End If
With wb.ActiveSheet
.Name = kk
For j = 1 To 13
.Range(rr(j - 1)) = arr(xh, j)
Next j
h = 9
For j = 14 To 18 Step 2
h = h + 1
.Cells(h, 2) = arr(xh, j)
.Cells(h, 7) = arr(xh, j + 1)
Next j
h = 13
For j = 20 To 24 Step 2
h = h + 1
.Cells(h, 2) = arr(xh, j)
.Cells(h, 7) = arr(xh, j + 1)
Next j
h = 17
For j = 26 To 30 Step 2
h = h + 1
.Cells(h, 2) = arr(xh, j)
.Cells(h, 7) = arr(xh, j + 1)
Next j
h = 21
For j = 32 To 35 Step 1
h = h + 1
.Cells(h, 2) = arr(xh, j)
Next j
End With
Next kk
wb.SaveAs Filename:=lj & nf & "年\" & yf & "月\" & k & ".xlsx"
wb.Close
Next k
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "导出完毕,用时:" & Format(Timer - tt, "#0.00") & " 秒", , "棋子提示"
End Sub
|
评分
-
1
查看全部评分
-
|