二维表转换

quqiyuan

参与一下

ykcbf1100

ddz79101 发表于 2024-5-8 15:39
谢谢老师！运行成功！只是我想将你代码其另存表时：
sheet2.[a:m].Clear
    sheet2.[a1].Resize(1, n  ...

我的附件肯定是可以的，你修改后我就不知道了。
你可以上传附件看看。

ddz79101

ykcbf1100 发表于 2024-5-8 16:19
我的附件肯定是可以的，你修改后我就不知道了。
你可以上传附件看看。

老师1我意思是将结果另存表时横向合计没有出来。请帮忙看看

quqiyuan

改了下，供参考

baofa2

ddz79101

baofa2 发表于 2024-5-8 18:19

谢谢老师！你指出的我的问题，是我往下拉复制时的错误，我在正式运行时修改了。谢谢你的指点，使我避免运行时出错。

ykcbf1100

ddz79101 发表于 2024-5-8 16:44
老师1我意思是将结果另存表时横向合计没有出来。请帮忙看看

改好了。。。

ykcbf1100

更新一下。。。

1. Sub ykcbf()  '//2024.5.8
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Sheets("Sheet1")
   
7.         r = .Cells(Rows.Count, 2).End(3).Row
   
8.         arr = .Range("a1").Resize(r, 8)
   
9.     End With
   
10.     ReDim brr(1 To UBound(arr), 1 To 100)
    
11.     brr(1, 1) = arr(1, 2)
    
12.     m = 1: n = 1
    
13.     On Error Resume Next
    
14.     For i = 2 To UBound(arr)
    
15.         s = Month(arr(i, 1))
    
16.         If Not d.exists(s) Then
    
17.             n = n + 1
    
18.             d(s) = n
    
19.             brr(1, n) = s & "月"
    
20.         End If
    
21.         s = arr(i, 2)
    
22.         If Not d.exists(s) Then
    
23.             m = m + 1
    
24.             d(s) = m
    
25.             brr(m, 1) = s
    
26.         End If
    
27.         r = d(arr(i, 2)): c = d(Month(arr(i, 1)))
    
28.         brr(r, c) = brr(r, c) + arr(i, 8)
    
29.     Next
    
30.     With Sheets("Sheet2")
    
31.         .UsedRange.Clear
    
32.         .[a1].Resize(1, n + 1).Interior.Color = 49407
    
33.         With .[a1].Resize(m + 1, n + 1)
    
34.             .Value = brr
    
35.             .Borders.LineStyle = 1
    
36.             .HorizontalAlignment = xlCenter
    
37.             .VerticalAlignment = xlCenter
    
38.             With .Font
    
39.                 .Name = "微软雅黑"
    
40.                 .Size = 11
    
41.             End With
    
42.         End With
    
43.         .Cells(1, n + 1) = "合计"
    
44.         For i = 2 To m + 1
    
45.            .Cells(i, n + 1) = Application.Sum(.Range(.Cells(i, "b"), .Cells(i, n)))
    
46.         Next
    
47.         m = m + 1
    
48.         .Cells(m, "a") = "合计"
    
49.         .Cells(m, "b").Resize(1, n).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
50.     End With
    
51.     Set d = Nothing
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码

ddz79101

ykcbf1100 发表于 2024-5-8 19:06
改好了。。。

谢谢老师！运行成功！

ddz79101

quqiyuan 发表于 2024-5-8 16:02
参与一下

谢谢老师！运行成功！