双重透视

ddz79101 · 发表于 2024-9-16 22:59

lizhipei78 发表于 2024-9-16 22:44
一维转二维，全自动生成

谢谢老师！运行后有2个问题：1是结果不对，工伤赫尔附加医疗险，个人是没有的（政策规定簿用承担）。2就是感觉运行中有几次提示，这提示可以或略的，提示了反而感觉不丝滑，能否取消。谢谢老师！花后补。

quqiyuan · 发表于 2024-9-16 23:03

本帖最后由 quqiyuan 于 2024-9-17 07:04 编辑

lizhipei78 发表于 2024-9-16 22:48
你这个是让人家就是固定就这么多项，少一项或者多一项，你这个都是错误的，你试删除其中一项，如养老险

可以全部生成，不过开始没想到那么多嘛，有表头就方便一点，代码短些。。。

quqiyuan · 发表于 2024-9-16 23:04

代码如下。。。
Sub test1()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim d
Dim dic
Dim brr(1 To 10000, 1 To 100)
Dim Brow, Bcol
Dim arr, x, k, kk, kkk
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
With Sheet4
      arr = .Range("a1:e" & .Range("a65536").End(xlUp).Row)
      For i = 2 To UBound(arr)
         s = arr(i, 2)
         If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
         For j = 4 To 5
            ss = arr(i, 3) & "|" & arr(1, j)
            sss = arr(i, j)
            If sss <> Empty Then
                  d(s)(ss) = sss
                  If Not dic.Exists(arr(1, j)) Then Set dic(arr(1, j)) = CreateObject("scripting.dictionary")
                  dic(arr(1, j))(arr(i, 3)) = ""
            End If
         Next
      Next
      brr(1, 1) = "序号": brr(1, 2) = "姓名"
      x = 2
      For Each k In d.Keys
         x = x + 1
         brr(x, 1) = x - 2
         brr(x, 2) = k
         j = 2: Sum = 0
         For Each k1 In dic.Keys
            For Each k2 In dic(k1).Keys
                  If d(k).Exists(k2 & "|" & k1) Then
                     j = j + 1
                     brr(1, j) = k1
                     brr(2, j) = k2
                     brr(x, j) = d(k)(k2 & "|" & k1)
                     Sum = Sum + brr(x, j)
                  End If
            Next
            j = j + 1
            brr(1, j) = k1
            brr(2, j) = "小计"
            brr(x, j) = "=sum(rc[-1]:rc[" & -dic(k1).Count & "])"
         Next
         brr(x, j + 1) = Sum
         brr(1, j + 1) = "合计"
         y = Application.Max(y, j + 1)
      Next
End With
With ThisWorkbook.Sheets("案例")
      .[a1].CurrentRegion.Clear
      .[a1].Resize(x, y) = brr
      .[a1].Resize(2, 1).Merge
      .[b1].Resize(2, 1).Merge
      .[a1].Offset(, y - 1).Resize(2, 1).Merge
      .Cells(x + 1, "a").Resize(, 2).Merge
      .Cells(x + 1, "a") = "合计"
      For i = y - 1 To 4 Step -1
         If .Cells(1, i) = .Cells(1, i - 1) Then .Range(.Cells(1, i), .Cells(1, i - 1)).Merge
      Next
      .[a1].CurrentRegion.HorizontalAlignment = xlCenter
      .[a1].CurrentRegion.Borders.LineStyle = 1
      .[a1].CurrentRegion.Font.Size = 10
      .Cells(x + 1, "c").Resize(, y - 2) = "=sum(r[-1]c:r[" & -x + 2 & "]c)"
End With
Set d = Nothing
Set dic = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Beep
End Sub

ddz79101 · 发表于 2024-9-17 00:57

quqiyuan 发表于 2024-9-16 23:04
代码如下。。。
Sub test1()
Application.DisplayAlerts = False

谢谢老师！运行完美成功！我是使用者，所以知道实际情况。花后补

wang-way · 发表于 2024-9-17 01:47

lizhipei78 · 发表于 2024-9-17 08:06

ddz79101 发表于 2024-9-16 22:59
谢谢老师！运行后有2个问题：1是结果不对，工伤赫尔附加医疗险，个人是没有的（政策规定簿用承担）。2就 ...

不好意思，已经更正

一维转二维9.17.rar (21.86 KB, 下载次数: 10)

lizhipei78 · 发表于 2024-9-17 08:22

弄了两个，一个是删除空的项，一个是保留空的项目

一维转二维9.17.rar (25.03 KB, 下载次数: 16)

Qs18 · 发表于 2024-9-17 13:56

Sub qs()
Application.DisplayAlerts = False
Dim arr, i, dic
Set dic = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
With Sheet4
arr = .Range("a1").CurrentRegion.Value
For c = 4 To 5
s = arr(1, c)
For i = 2 To UBound(arr)
s2 = arr(i, 2): s3 = arr(i, 3)
If Not dic.Exists(s) Then Set dic(s) = CreateObject("scripting.dictionary")
If Not dic(s).Exists(s2) Then Set dic(s)(s2) = CreateObject("scripting.dictionary")
dic(s)(s2)(s3) = arr(i, c)
If arr(i, c) <> Empty Then
If Not d2.Exists(s) Then Set d2(s) = CreateObject("scripting.dictionary")
d2(s)(s3) = ""
End If
d3(s2) = ""
Next i
Next c
ReDim hrr(1 To 2, 1 To 13)
hrr(1, 1) = "序号": hrr(1, 2) = "姓名": hrr(1, 13) = "合计"
cc = 2
For Each dk2 In d2.Keys
For Each dk3 In d2(dk2).Keys
cc = cc + 1
hrr(1, cc) = dk2
hrr(2, cc) = dk3
Next
cc = cc + 1
hrr(1, cc) = "小计": hrr(2, cc) = "小计"
Next dk2
rw = d3.Count
ReDim brr(1 To rw, 1 To UBound(hrr, 2))
For Each k In d3.Keys
m = m + 1
brr(m, 1) = m: brr(m, 2) = k
Next
For i = 1 To m
For j = 3 To 11
If hrr(1, j) <> "小计" Then
brr(i, j) = dic(hrr(1, j))(brr(i, 2))(hrr(2, j))
End If
Next
sm1 = 0: sm2 = 0
For col = 3 To 7
sm1 = sm1 + brr(i, col)
Next
For col2 = 9 To 11
sm2 = sm2 + brr(i, col2)
Next
brr(i, 8) = sm1: brr(i, 12) = sm2
brr(i, 13) = sm1 + sm2
Next i
ReDim Err(1 To 1, 1 To 13)
Err(1, 2) = "合计"
For cl = 3 To 13
Err(1, cl) = Application.Sum(Application.Index(brr, 0, cl))
Next
.Range("h12").Resize(10000, 13).Clear
.Range("h12").Resize(2, 13) = hrr
.Range("h14").Resize(m, 13) = brr
.Range("h14").Offset(m).Resize(1, 13) = Err
With .Range("h12").CurrentRegion
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormat = "0.00"
End With
.Range("h12:h13").Merge: .Range("i12:i13").Merge: .Range("t12:t13").Merge
.Range("j12:o12").Merge: .Range("p12:s12").Merge
End With
Set dic = Nothing: Set d2 = Nothing: Set d3 = Nothing
Application.DisplayAlerts = True
End Sub

复制代码

Qs18 · 发表于 2024-9-17 14:00

试试。。。。。。。。

Qs18 · 发表于 2024-9-17 14:01

试试。。。。。。。。

		自动登录	找回密码
密码			免费注册

[求助] 双重透视

评分

评分