分拆表并提取拆表单元格数值

xing_chen

lushang2018 发表于 2023-2-4 09:04

lushang2018老师，可帮忙看看嘛

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！发错

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！发错

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！发错

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！发错

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！撤销发错

xing_chen

lushang2018 发表于 2023-2-4 09:04

下架！撤销发错

lushang2018

xing_chen 发表于 2023-2-5 22:03
lushang2018老师，可帮忙看看嘛

1. Sub 分拆()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim i, j, k, m, n, arr, brr, crr, drr
   
5.     Dim sht As Worksheet, wbk As Workbook, rng As Range
   
6.     Dim dic As Object, key As String, keys, items
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.     For Each sht In ThisWorkbook.Worksheets
   
9.         If Len(sht.Name) < 3 Then
   
10.             Sheets.Add after:=sht
    
11.             ActiveSheet.Name = sht.Name & "拆1"
    
12.             Sheets.Add after:=Sheets(sht.Name & "拆1")
    
13.             ActiveSheet.Name = sht.Name & "拆2"
    
14.             sht.Range("A1:h1").Copy Sheets(sht.Name & "拆1").Range("A1")
    
15.             sht.Range("A1:h1").Copy Sheets(sht.Name & "拆2").Range("A1") '到此句止创建了拆表和拆表里复制的列名
    
16.             arr = sht.Range("A1").CurrentRegion.Value
    
17.             Sheets(sht.Name & "拆1").Range("A2").Resize(100, 8) = 去重(arr)
    
18.             Sheets(sht.Name & "拆2").Range("A2").Resize(100, 8) = 汇总(arr)
    
19.         End If
    
20.     Next
    
21.     Application.ScreenUpdating = True
    
22.     Application.DisplayAlerts = True
    
23. End Sub
    
24. Function 去重(arr)
    
25.     Dim i, j, k, brr
    
26.     Dim dic As Object, key As String, keys, Item, dicItems
    
27.     Set dic = CreateObject("scripting.dictionary")
    
28.     ReDim brr(1 To 8)
    
29.     For i = 2 To UBound(arr)
    
30.         key = arr(i, 2)
    
31.         If Not dic.Exists(key) Then
    
32.             For j = 1 To 8
    
33.                 brr(j) = arr(i, j)
    
34.             Next
    
35.             dic(key) = brr
    
36.         Else
    
37.             brr = dic(key)
    
38.             brr(3) = brr(3) + arr(i, 4)
    
39.             brr(4) = brr(4) + arr(i, 5)
    
40.             dic(key) = brr
    
41.         End If
    
42.     Next
    
43.     keys = dic.keys
    
44.     ReDim crr(1 To 100, 1 To 8)
    
45.     For i = 1 To dic.Count
    
46.         key = keys(i - 1)
    
47.         brr = dic(key)
    
48.         For j = 1 To 8
    
49.             crr(i, j) = brr(j)
    
50.         Next
    
51.     Next
    
52.     去重 = crr
    
53. End Function
    
54. Function 汇总(arr)
    
55.     Dim i, j, k, brr, 累计
    
56.     ReDim brr(1 To 1000, 1 To 8)
    
57.     For i = 2 To UBound(arr)
    
58.         If arr(i, 2) = "个人" Then
    
59.             k = k + 1
    
60.             For j = 1 To 8
    
61.                 brr(k, j) = arr(i, j)
    
62.             Next
    
63.             累计 = 累计 + arr(i, 5)
    
64.         End If
    
65.         brr(k + 1, 3) = "小计"
    
66.         brr(k + 1, 5) = 累计
    
67.     Next
    
68.     汇总 = brr
    
69. End Function
    

复制代码

xing_chen

lushang2018 发表于 2023-2-6 11:33

谢谢老师！运行如愿！还是您修改的简单！我的太复杂了。对照你的，再学习一下。谢谢！