修改代码

ddz79101

老师，有个表格，我希望转换成二维表，写有代码，但不成功。请老师帮忙看看。谢谢

jaxxcyh

数据透视表10秒搞定！

ddz79101

jaxxcyh 发表于 2024-9-16 13:46
数据透视表10秒搞定！

谢谢老师！发错了，看这附件。上面1楼附件也已重发.老师我希望用代码。谢谢

ddz79101

ddz79101 发表于 2024-9-16 14:06
谢谢老师！发错了，看这附件。上面1楼附件也已重发.老师我希望用代码。谢谢

怎么没有反应。老师们看看

jaxxcyh

1. Sub 下棋法之数据透视表式汇总()
   
2. Dim d As New Dictionary
   
3. Dim 棋盘(1 To 10000, 1 To 8)    '加个合计列
   
4. Dim 行数, 列数
   
5. Dim arr, x, k
   
6. arr = Range("A2:C" & Range("C65536").End(xlUp).Row)
   
7. For x = 1 To UBound(arr)
   
8.     列数 = Left(arr(x, 2), 1) + 1     '获取月份转化为列数
   
9.     If d.Exists(arr(x, 1)) Then
   
10.         行数 = d(arr(x, 1))            '从字典里取出产品类别对应的行数
    
11.         棋盘(行数, 列数) = 棋盘(行数, 列数) + arr(x, 3)   '同时汇总此月份费用
    
12.     Else
    
13.         k = k + 1                     '依次向字典里存储产品类别对应的行数，A-1,B-2,C-3,...
    
14.         d(arr(x, 1)) = k
    
15.         棋盘(k, 1) = arr(x, 1)        '填入产品类别
    
16.         棋盘(k, 列数) = arr(x, 3)     '填入第一个费用（后续在此基础上累加）
    
17.     End If
    
18. Next x
    
19. 
    
20. For i = 1 To d.Count + 1
    
21.     For j = 2 To UBound(棋盘, 2) - 1
    
22.         棋盘(i, 8) = 棋盘(i, 8) + 棋盘(i, j)
    
23.         If i <> d.Count + 1 Then 棋盘(d.Count + 1, j) = 棋盘(d.Count + 1, j) + 棋盘(i, j)
    
24.     Next
    
25. Next
    
26.    
    
27. 棋盘(d.Count + 1, 1) = "总计"
    
28. Range("F2").Resize(k + 1, 8) = 棋盘
    
29. 
    
30. End Sub
    
31. 
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, r&, c&, dic As Object, iPosRow&, iPosCol&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    ReDim br(1 To UBound(ar), 1 To UBound(ar) + 1)
    br(1, 1) = "序号": br(1, 2) = "姓名"
    r = 1: c = 2
   
    For i = 2 To UBound(ar)
        If Not dic.Exists(ar(i, 2)) Then
            r = r + 1
            br(r, 1) = r - 1
            br(r, 2) = ar(i, 2)
            dic(br(r, 2)) = r
        End If
        If Not dic.Exists(ar(i, 3)) Then
            c = c + 1
            br(1, c) = ar(i, 3)
            dic(br(1, c)) = c
        End If
        iPosRow = dic(ar(i, 2)): iPosCol = dic(ar(i, 3))
        br(iPosRow, iPosCol) = ar(i, 4)
    Next i
   
    [H1].CurrentRegion.Clear
    With [H1].Resize(r, c)
       .Value = br
       .Borders.LineStyle = xlContinuous
        .EntireColumn.AutoFit
    End With
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。。。

ykcbf1100

全表自动生成，字典+数组

ykcbf1100

全表自动生成

1. Sub ykcbf()   '//2024.9.16
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     m = 1: n = 2
   
7.     On Error Resume Next
   
8.     With Sheets("Sheet1")
   
9.         r = .Cells(Rows.Count, 1).End(3).Row
   
10.         arr = .[a1].Resize(r, 4)
    
11.     End With
    
12.      brr(1, 1) = arr(1, 1): brr(1, 2) = arr(1, 2)
    
13.     For i = 2 To UBound(arr)
    
14.         s = arr(i, 2)
    
15.         If Not d.Exists(s) Then
    
16.             m = m + 1
    
17.             d(s) = m
    
18.             brr(m, 1) = m - 1
    
19.             brr(m, 2) = s
    
20.         End If
    
21.         r = d(arr(i, 2))
    
22.         s = arr(i, 3)
    
23.         If Not d.Exists(s) Then
    
24.             n = n + 1
    
25.             d(s) = n
    
26.             brr(1, n) = s
    
27.         End If
    
28.         c = d(arr(i, 3))
    
29.         brr(r, c) = brr(r, c) + arr(i, 4)
    
30.     Next
    
31.     With Sheets("Sheet2")
    
32.         .UsedRange.Clear
    
33.         .Cells.Interior.ColorIndex = 0
    
34.         .[a1].Resize(1, n).Interior.Color = 49407
    
35.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
36.         With .[a1].Resize(m, n)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.             With .Font
    
42.                 .Name = "微软雅黑"
    
43.                 .Size = 11
    
44.             End With
    
45.         End With
    
46.     End With
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

jaxxcyh

ddz79101 发表于 2024-9-16 14:06
谢谢老师！发错了，看这附件。上面1楼附件也已重发.老师我希望用代码。谢谢

1. Sub 汇总()
   
2.     Dim d As New Dictionary
   
3.     Dim brr(1 To 10000, 1 To 5)
   
4.     Dim Brow, Bcol
   
5.     Dim arr, x, k
   
6.     arr = Range("a2:d" & Range("a65536").End(xlUp).Row)
   
7.     For x = 1 To UBound(arr)
   
8.         Bcol = (InStr("语文数学英语", arr(x, 3)) + 1) / 2 + 2   '获取学科应从arr第3列获取而不是第2列
   
9.         If d.Exists(arr(x, 2)) Then
   
10.             Brow = d(arr(x, 2))
    
11.             brr(Brow, Bcol) = brr(Brow, Bcol) + arr(x, 4)
    
12.         Else
    
13.             k = k + 1
    
14.             d(arr(x, 2)) = k
    
15.             brr(k, 2) = arr(x, 2)
    
16.             brr(k, Bcol) = arr(x, 4)
    
17.         End If
    
18.         brr(k, 1) = k   '添加序号
    
19.     Next x
    
20.    
    
21.     Range("f2").Resize(k, 5) = brr
    
22. End Sub
    

复制代码