|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("总表")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:h" & r)
- End With
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 8)) Then
- m = 1
- ReDim brr(1 To 6, 1 To m)
- Else
- brr = d(arr(i, 8))
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To 6, 1 To m)
- End If
- brr(1, m) = arr(i, 3)
- brr(2, m) = arr(i, 2)
- brr(3, m) = arr(i, 4)
- brr(4, m) = arr(i, 5)
- brr(5, m) = arr(i, 6)
- brr(6, m) = arr(i, 7)
- d(arr(i, 8)) = brr
- Next
- For Each aa In d.keys
- brr = d(aa)
- On Error Resume Next
- Set ws = Worksheets(aa)
- If Err = 0 Then
- On Error GoTo 0
- With ws
- .Range("b2").Resize(12, .Columns.Count - 1).ClearContents
- .Range("b2").Resize(UBound(brr), UBound(brr, 2)) = brr
- End With
- End If
- Next
- Application.ScreenUpdating = True
- MsgBox "数据拆分完毕!"
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|