|
|
- Sub 分拆()
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Dim i, j, k, m, n, arr, brr, crr, drr
- Dim sht As Worksheet, wbk As Workbook, rng As Range
- Dim dic As Object, key As String, keys, items
- Set dic = CreateObject("scripting.dictionary")
- For Each sht In ThisWorkbook.Worksheets
- If Len(sht.Name) < 3 Then
- Sheets.Add after:=sht
- ActiveSheet.Name = sht.Name & "拆1"
- Sheets.Add after:=Sheets(sht.Name & "拆1")
- ActiveSheet.Name = sht.Name & "拆2"
- sht.Range("A1:h1").Copy Sheets(sht.Name & "拆1").Range("A1")
- sht.Range("A1:h1").Copy Sheets(sht.Name & "拆2").Range("A1") '到此句止创建了拆表和拆表里复制的列名
- arr = sht.Range("A1").CurrentRegion.Value
- Sheets(sht.Name & "拆1").Range("A2").Resize(100, 8) = 去重(arr)
- Sheets(sht.Name & "拆2").Range("A2").Resize(100, 8) = 汇总(arr)
- End If
- Next
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
- Function 去重(arr)
- Dim i, j, k, brr
- Dim dic As Object, key As String, keys, Item, dicItems
- Set dic = CreateObject("scripting.dictionary")
- ReDim brr(1 To 8)
- For i = 2 To UBound(arr)
- key = arr(i, 2)
- If Not dic.Exists(key) Then
- For j = 1 To 8
- brr(j) = arr(i, j)
- Next
- dic(key) = brr
- Else
- brr = dic(key)
- brr(3) = brr(3) + arr(i, 4)
- brr(4) = brr(4) + arr(i, 5)
- dic(key) = brr
- End If
- Next
- keys = dic.keys
- ReDim crr(1 To 100, 1 To 8)
- For i = 1 To dic.Count
- key = keys(i - 1)
- brr = dic(key)
- For j = 1 To 8
- crr(i, j) = brr(j)
- Next
- Next
- 去重 = crr
- End Function
- Function 汇总(arr)
- Dim i, j, k, brr, 累计
- ReDim brr(1 To 1000, 1 To 8)
- For i = 2 To UBound(arr)
- If arr(i, 2) = "个人" Then
- k = k + 1
- For j = 1 To 8
- brr(k, j) = arr(i, j)
- Next
- 累计 = 累计 + arr(i, 5)
- End If
- brr(k + 1, 3) = "小计"
- brr(k + 1, 5) = 累计
- Next
- 汇总 = brr
- End Function
|
评分
-
1
查看全部评分
-
|
楼主: xing_chen
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2023-2-6 11:33