表格规范化

xing_chen

老师，有表，因需要标准化，现有数据需要移行和列。虽有向老师求助，但因VBA的掌握有限和刚对报表格式的理解，特再请老师赐教。谢谢！

准提部林

源數據與上一帖又不同,
是來學習?? 還是測試?

那源數據應還是虛擬的吧! 結構不同, 代碼寫法不同..
到時又要一改再改...

xing_chen

准提部林 发表于 2023-2-13 21:18
源數據與上一帖又不同,
是來學習?? 還是測試?

老师你好！上一贴是没有领会老板意图，按一般理解的。现在说要通行标准化。至于数据我原想简单化，只要不留空行即可，后说要移上。现在说要单独另列醒目。
学习倒是在学习。一旦工作时又改进效率的时候，就想法改进。犹如有游戏瘾。自我感觉也不好!
至于测试，物的对象倒是没有，只有如履薄冰面对的对象

xing_chen

xing_chen 发表于 2023-2-13 21:37
老师你好！上一贴是没有领会老板意图，按一般理解的。现在说要通行标准化。至于数据我原想简单化，只要不 ...

有老师帮忙解决我的问题吗！根据单元格行并移动行的位置，这代码字母写呀?

xing_chen

xing_chen 发表于 2023-2-13 23:04
有老师帮忙解决我的问题吗！根据单元格行并移动行的位置，这代码字母写呀?

夜半三个更额盼黎明，寒冬腊月额盼春天。闪闪的灯光

ykcbf1100

还是字典嵌字典吧。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:c" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             xm = Split(arr(i, 1), " ")
    
11.             If Not d.exists(xm(0)) Then
    
12.                 Set d(xm(0)) = CreateObject("scripting.dictionary")
    
13.             End If
    
14.             If Not d(xm(0)).exists(xm(1)) Then
    
15.                 ReDim brr(1 To 4)
    
16.                 brr(1) = xm(1)
    
17.                 brr(4) = arr(i, 2)
    
18.             Else
    
19.                 brr = d(xm(0))(xm(1))
    
20.             End If
    
21.             brr(3) = brr(3) + arr(i, 3)
    
22.             d(xm(0))(xm(1)) = brr
    
23.         Next
    
24.         .Range("n2:q" & .Rows.Count).Clear
    
25.         r = 2
    
26.         For Each aa In d.keys
    
27.             .Cells(r, 14) = aa & "小计"
    
28.             ReDim crr(1 To d(aa).Count, 1 To 4)
    
29.             m = 0
    
30.             xj = 0
    
31.             For Each bb In d(aa).keys
    
32.                 brr = d(aa)(bb)
    
33.                 m = m + 1
    
34.                 For j = 1 To UBound(brr)
    
35.                     crr(m, j) = brr(j)
    
36.                 Next
    
37.                 xj = xj + brr(3)
    
38.             Next
    
39.             .Cells(r, 15) = xj
    
40.             .Cells(r + 1, 14).Resize(UBound(crr), UBound(crr, 2)) = crr
    
41.             With .Cells(r, 14).Resize(1 + UBound(crr), UBound(crr, 2))
    
42.                 .Borders.LineStyle = xlContinuous
    
43.                 With .Font
    
44.                     .Name = "微软雅黑"
    
45.                     .Size = 10
    
46.                 End With
    
47.             End With
    
48.             r = r + 1 + UBound(crr)
    
49.         Next
    
50.     End With
    
51. End Sub
    

复制代码

chxw68

详见附件。

xing_chen

ykcbf1100 发表于 2023-2-14 10:59
还是字典嵌字典吧。

谢谢老师！运行如愿！特别感谢你对我的想法变化还继续不厌其烦。

xing_chen

chxw68 发表于 2023-2-14 11:03
详见附件。

谢谢老师！运行如愿。谢谢你的出手！