双重透视

ddz79101 · 发表于 2024-9-16 18:14

老师！有表，含2条件并有2列数据，需整理成双重透视。轻轻老师帮忙看看，

quqiyuan · 发表于 2024-9-16 18:49

本帖最后由 quqiyuan 于 2024-9-16 19:52 编辑

参与一下，仅供参考。。。

quqiyuan · 发表于 2024-9-16 18:50

代码如下。。。
Sub test()
Dim d As New Dictionary
Dim brr(1 To 10000, 1 To 13)
Dim Brow, Bcol
Dim arr, x, k, kk, kkk
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)
            d(s)(ss) = sss
         Next
      Next
      biaoti = .[h1:t2]
      For i = 2 To UBound(biaoti, 2)
         If biaoti(1, i) = "" Then biaoti(1, i) = biaoti(1, i - 1)
      Next
      For Each k In d.Keys
         x = x + 1
         brr(x, 1) = x
         brr(x, 2) = k
         Key = d(k).Keys
         For Each kk In d(k).Keys
            For j = 3 To UBound(biaoti, 2)
                  brr(x, j) = d(k)(biaoti(2, j) & "|" & biaoti(1, j))
            Next
            brr(x, 8) = "=sum(rc[-1]:rc[-5])"
            brr(x, 12) = "=sum(rc[-1]:rc[-3])"
            brr(x, 13) = "=sum(rc[-1],rc[-5])"
         Next
      Next
      .[h2].CurrentRegion.Offset(2) = Empty
      .[h3].Resize(x, 13) = brr
End With
Set d = Nothing
Beep
End Sub

ykcbf1100 · 发表于 2024-9-16 18:55

本帖最后由 ykcbf1100 于 2024-9-16 18:58 编辑

全表自动生成

ykcbf1100 · 发表于 2024-9-16 18:57

表格转换，全表自动生成

Sub ykcbf() '//2024.9.16
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
ReDim brr(1 To 10000, 1 To 100)
ReDim zrr(1 To 100)
m = 2: n = 2
On Error Resume Next
With Sheets("Sheet1")
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 5)
End With
brr(1, 1) = arr(1, 1): brr(1, 2) = arr(1, 2)
For j = 4 To UBound(arr, 2)
x = x + 1
For i = 2 To UBound(arr)
s = arr(i, 2)
If Not d.Exists(s) Then
m = m + 1
d(s) = m
brr(m, 1) = Format(m - 2, "00")
brr(m, 2) = s
End If
r = d(arr(i, 2))
If arr(i, j) <> Empty Then
s = arr(1, j) & "|" & arr(i, 3)
If Not d.Exists(s) Then
n = n + 1
d(s) = n
brr(1, n) = arr(1, j)
brr(2, n) = arr(i, 3)
End If
c = d(arr(1, j) & "|" & arr(i, 3))
brr(r, c) = brr(r, c) + arr(i, j)
End If
Next
n = n + 1
d(arr(1, j) & "|" & "小计") = n
brr(1, n) = arr(1, j): brr(2, n) = "小计"
zrr(x) = n
Next
n = n + 1
brr(1, n) = "合计"
With Sheets("Sheet2")
.UsedRange.Clear
.Cells.Interior.ColorIndex = 0
.[a1].Resize(1, n).Interior.Color = 49407
.[a3].Resize(m - 2, 1).Interior.Color = 5296274
.Columns(1).NumberFormatLocal = "@"
With .[a1].Resize(m + 1, n)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Font
.Name = "微软雅黑"
.Size = 11
End With
End With
.[a1].Resize(2).Merge
.[b1].Resize(2).Merge
.Cells(1, n).Resize(2).Merge
.Cells(1, 3).Resize(, zrr(1) - 2).Merge
.Cells(1, zrr(1) + 1).Resize(, zrr(2) - zrr(1)).Merge
For i = 3 To m
.Cells(i, zrr(1)) = Application.Sum(.Cells(i, 3).Resize(, zrr(1) - 3))
.Cells(i, zrr(2)) = Application.Sum(.Cells(i, zrr(1) + 1).Resize(, zrr(2) - zrr(1) - 1))
.Cells(i, n) = .Cells(i, zrr(1)) + .Cells(i, zrr(2))
Next
m = m + 1
.Cells(m, 1) = "合计": .Cells(m, 1).Resize(, 2).Merge
For j = 3 To n
.Cells(m, j) = Application.Sum(.Cells(3, j).Resize(m - 3))
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

cnmlgb9998 · 发表于 2024-9-16 19:48

PQ 解决。

就是一个体力活。。。。。。。。。

let
源 = Excel.CurrentWorkbook(){[Name = "表1"]}[Content],
Unpivot = Table.UnpivotOtherColumns(源, {"姓名", "险种"}, "属性", "值"),
Com = Table.CombineColumns(
Unpivot,
{"属性", "险种"},
Combiner.CombineTextByDelimiter("-", QuoteStyle.None),
"已合并"
),
Pivot = Table.Pivot(Com, List.Distinct(Com[已合并]), "已合并", "值", List.Sum),
Tab1 = Table.DemoteHeaders(Pivot),
Tab2 = List.Accumulate(
List.Skip(Table.ColumnNames(Tab1)),
Tab1,
(x, y) =>
Table.ReplaceValue(
x,
"",
"",
(o, p, q) => if Text.Contains(Text.From(o), "-") then Text.Split(o, "-") else o,
{y}
)
),
Tab3 = Table.TransformColumns(
Table.Transpose(Tab2),
{"Column1", each if _ = "姓名" then {_, ""} else _}
),
Tran = Table.TransformColumns(
Tab3,
{"Column1", each Text.Combine(List.Transform(_, Text.From), "-"), type text}
),
Tab4 = Table.SplitColumn(
Tran,
"Column1",
Splitter.SplitTextByDelimiter("-", QuoteStyle.Csv),
{"Column1.1", "Column1.2"}
),
Group1 = Table.Group(Tab4, List.First(Table.ColumnNames(Tab4)), {"Data", each _})[Data],
Sum1 = {List.First(Group1)}
& List.Transform(
List.Skip(Group1),
each [
a = Table.Group(
_,
{},
List.Transform(
List.Skip(Table.ColumnNames(_)),
(x) => {
x,
(y) =>
try
List.Sum(List.Transform(Table.Column(_, x), (z) => Number.From(z)))
otherwise
"小计"
}
)
),
b = _ & a
][b]
),
Tab5 = Table.Combine(List.Transform(List.Skip(Sum1), each Table.LastN(_, 1))),
Sum2 = Table.Group(
Tab5,
{},
List.Transform(
List.Skip(Table.ColumnNames(Tab5)),
each {_, (x) => try List.Sum(Table.Column(Tab5, _)) otherwise "合计"}
)
),
Tab6 = Table.Combine(Sum1 & {Sum2}),
Tran2 = Table.Transpose(Tab6),
Res = Tran2
& Table.Group(
Tran2,
{},
List.Transform(
Table.ColumnNames(Tran2),
each {_, (x) => try List.Sum(List.Skip(Table.Column(Tran2, _), 2)) otherwise "总计"}
)
)
in
Res

复制代码

cnmlgb9998 · 发表于 2024-9-16 19:50

审核能审个啥出来？

用PQ解决，是这个效果吗？？？？？？？？？？

Qs18 · 发表于 2024-9-16 20:25

Sub qs()
Dim arr, i, dic
Set dic = 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)
Next i
Next c
brr = .Range("i1:n8").Value
For j = 2 To 6
For i = 3 To 8
brr(i, j) = dic(brr(1, 2))(brr(i, 1))(brr(2, j))
Next i
Next j
For i = 3 To 8
.Range("i" & i).Resize(1, 6) = Application.Index(brr, i, 0)
Next i
crr = .Range("p1:r8").Value
For j = 1 To 3
For i = 3 To 8
crr(i, j) = dic(crr(1, 1))(brr(i, 1))(crr(2, j))
Next
Next
For i = 3 To 8
.Range("p" & i).Resize(1, 3) = Application.Index(crr, i, 0)
Next i
End With
Set dic = Nothing
End Sub

复制代码

Qs18 · 发表于 2024-9-16 20:26

试试。。。。。。。。

Qs18 · 发表于 2024-9-16 20:28

试试。。。。。

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

[求助] 双重透视

评分

评分

评分

评分

评分

评分