|
楼主 |
发表于 2016-8-31 16:58
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- For Each ws In Worksheets
- If ws.Name <> "总" And ws.Name <> "模板" Then
- ws.Delete
- End If
- Next
- With Worksheets("总")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(4, .Columns.Count).End(xlToLeft).Column
- arr = .Range("a3").Resize(r - 2, c)
- For j = 2 To UBound(arr, 2)
- If Len(arr(1, j)) <> 0 Then
- xq = InStr("一二三四五六日", arr(1, j))
- End If
- If Not d.exists(arr(2, j)) Then
- ReDim brr(1 To 8, 1 To 5)
- Else
- brr = d(arr(2, j))
- End If
- For i = 3 To UBound(arr)
- If Len(arr(i, 1)) > 0 Then
- brr(arr(i, 1), xq) = arr(i, j)
- End If
- Next
- d(arr(2, j)) = brr
- Next
- End With
- d.Remove ("三5")
- With Worksheets("模板")
- .Range("c6:g7,c9:g10,c12:g14,k6:o7,k9:o10,k12:o14").ClearContents
- y = 2
- ss = ""
- kk = d.keys
- For Each aa In d.keys
- brr = d(aa)
- ss = ss & "|" & aa
- For i = 1 To UBound(brr)
- Select Case i
- Case Is <= 2
- x = i + 5
- Case Is <= 4
- x = i + 6
- Case Else
- x = i + 7
- End Select
- For j = 1 To UBound(brr, 2)
- .Cells(x, j + y) = brr(i, j)
- Next
- Next
- y = y + 8
- If y > 10 Or aa = kk(UBound(kk)) Then
- y = 2
- .Copy after:=Worksheets(Worksheets.Count)
- ActiveSheet.Name = Mid(ss, 2)
- ss = ""
- .Range("c6:g7,c9:g10,c12:g14,k6:o7,k9:o10,k12:o14").ClearContents
- End If
- Next
- End With
- End Sub
复制代码 |
|