vba 求助一维表转二维表

rendiule01

怎样把数据源格式转换为效果表那样的二维表样式？

合计数=三个公司金额总和-合并调整



报表明细.zip (32.15 KB, 下载次数: 6)

2024-11-23 20:30 上传

点击文件名下载附件

ykcbf1100

只转换公司数据就行吗？
标题不用自动生成吧？

shiruiqiang

虽然可以双字典、双嵌套，但你有些项目都没的，统计是不准的

rendiule01

ykcbf1100 发表于 2024-11-23 20:52
只转换公司数据就行吗？
标题不用自动生成吧？

老师，是的，报表的列标题都是固定的，位置不变，只是
行的数据是动态的，变化的

下面有几个月的，有个别月份行的数据有时少，有时多

3190496160

Sub 统计()
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("数据源")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:m" & r)
End With
With Sheets("效果")
    .UsedRange.Offset(2) = Empty
    br = .Range("a1:an" & r + 1)
    For j = 6 To UBound(br, 2)
        If br(1, j) = "" Then br(1, j) = br(1, j - 1)
        zd = br(1, j) & "|" & br(2, j)
        d(zd) = j
    Next j
    k = 2
    For i = 2 To UBound(ar)
        If ar(i, 1) <> "" And ar(i, 2) <> "" Then
            zf = ar(i, 1) & "|" & ar(i, 2) & "|" & ar(i, 3) & "|" & ar(i, 6)
            t = dc(zf)
            If t = "" Then
                k = k + 1
                dc(zf) = k
                t = k
                For j = 1 To 3
                    br(k, j) = ar(i, j)
                Next j
                For j = 5 To 6
                    br(k, j - 1) = ar(i, j)
                Next j
            End If
            For j = 7 To UBound(ar, 2)
                s = ar(1, j) & "|" & ar(i, 4)
                lh = d(s)
                If lh <> "" Then
                    br(t, lh) = br(t, lh) + ar(i, j)
                End If
            Next j
        End If
    Next i
    .[a1].Resize(k, UBound(br, 2)) = br
    For j = 10 To UBound(br, 2) Step 5
        For i = 3 To k
            .Cells(i, j).FormulaR1C1 = "=SUM(RC[-4]:RC[-2])-RC[-1]"
        Next i
    Next j
End With
MsgBox "ok!"
End Sub

3190496160

报表明细.rar (43.45 KB, 下载次数: 3)

2024-11-24 09:44 上传

点击文件名下载附件

ykcbf1100

rendiule01 发表于 2024-11-23 21:08
老师，是的，报表的列标题都是固定的，位置不变，只是
行的数据是动态的，变化的

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.11.24
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("数据源")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         c = .Cells(1, Columns.Count).End(1).Column
   
7.         arr = .[a1].Resize(r, c)
   
8.     End With
   
9.     ReDim brr(1 To r, 1 To 100)
   
10.     For i = 2 To UBound(arr)
    
11.         s1 = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
12.         If Not d.exists(s1) Then
    
13.             m = m + 1
    
14.             d(s1) = m
    
15.             brr(m, 1) = m
    
16.             brr(m, 2) = arr(i, 2)
    
17.             brr(m, 3) = arr(i, 3)
    
18.             brr(m, 4) = arr(i, 5)
    
19.             brr(m, 5) = arr(i, 6)
    
20.         End If
    
21.         For j = 7 To UBound(arr, 2)
    
22.             s = s1 & "|" & arr(i, 4) & "|" & arr(1, j)
    
23.             d(s) = d(s) + arr(i, j)
    
24.         Next
    
25.     Next
    
26.     With Sheets("效果")
    
27.         .UsedRange.Offset(2).ClearContents
    
28.         .[a3].Resize(m, 5) = brr
    
29.         arr = .UsedRange
    
30.         For i = 3 To UBound(arr)
    
31.             Sum = 0
    
32.             s1 = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3)
    
33.             For j = 6 To UBound(arr, 2) Step 5
    
34.                 For x = 1 To 3
    
35.                     s = s1 & "|" & arr(2, j + x - 1) & "|" & arr(1, j)
    
36.                     arr(i, j + x - 1) = d(s)
    
37.                     Sum = Sum + arr(i, j + x - 1)
    
38.                 Next
    
39.                 arr(i, j + 4) = Sum + arr(i, j + 3)
    
40.             Next
    
41.         Next
    
42.         .UsedRange = arr
    
43.     End With
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    

复制代码