如何使用代码实现根据汇总表中B列部门名称，提取其他表中内容

cnmlgb9998 · 发表于 2024-2-21 14:36

let
源 = Excel.Workbook(File.Contents("C:\Users\飞飞\Desktop\VBA\考核表.xlsx"), null, true),
筛选的行 = Table.SelectRows(源, each ([Kind] = "Sheet") and ([Item] <> "考核汇总")),
删除的列 = Table.RemoveColumns(筛选的行, {"Item", "Kind", "Hidden"}),
已添加自定义 = Table.AddColumn(
删除的列,
"转",
each Table.PromoteHeaders(
Table.FromColumns(
List.Zip(
List.Skip(List.Zip(Table.ToColumns([Data])), each not List.Contains(_, "序号"))
)
)
)
),
删除的其他列 = Table.SelectColumns(已添加自定义, {"Name", "转"}),
#"展开的“转”" = Table.ExpandTableColumn(
删除的其他列,
"转",
{"序号", "部门名称", "考核内容", "责任人", "小计"},
{"序号", "部门名称", "考核内容", "责任人", "小计"}
),
分组的行 = Table.Group(
#"展开的“转”",
{"部门名称"},
{
{
"ALL",
each _,
type table [序号 = number, 部门名称 = text, 考核内容 = text, 责任人 = text, 小计 = number]
}
}
),
排序的行 = Table.Sort(分组的行, {{"部门名称", Order.Ascending}}),
已添加自定义1 = Table.AddColumn(
排序的行,
"自定义",
each [
a = {"备注"} & List.Skip(Table.ColumnNames([ALL])),
b = List.Sum([ALL][小计]),
c = Table.ToRows([ALL]),
d = {"", "", "小计", "", "", b},
e = Table.RemoveColumns(Table.FromRows(List.Combine({c, {d}}), a), {"序号"})
][e]
),
删除的其他列1 = Table.SelectColumns(已添加自定义1, {"自定义"}),
#"展开的“自定义”" = Table.ExpandTableColumn(
删除的其他列1,
"自定义",
{"备注", "部门名称", "考核内容", "责任人", "小计"},
{"备注", "部门名称", "考核内容", "责任人", "小计"}
),
重排序的列 = Table.ReorderColumns(#"展开的“自定义”", {"部门名称", "考核内容", "责任人", "小计", "备注"})
in
重排序的列

复制代码

cnmlgb9998 · 发表于 2024-2-21 14:39

是要这个效果吗？PQ 可以实现

ykcbf1100 · 发表于 2024-2-21 15:06

cnmlgb9998 发表于 2024-2-21 14:39
是要这个效果吗？PQ 可以实现

我觉得这个表结构比楼主自己的表结构更合理一点。

xpmiemiezhou · 发表于 2024-2-21 16:41

ykcbf1100 发表于 2024-2-21 15:06
我觉得这个表结构比楼主自己的表结构更合理一点。

模版是规定死的，只能我那个模版

，就是我要在你代码基础上增加一列统计该如何改？

xpmiemiezhou · 发表于 2024-2-21 16:42

cnmlgb9998 发表于 2024-2-21 14:39
是要这个效果吗？PQ 可以实现

谢谢！！，但是不能改变原有模版

ykcbf1100 · 发表于 2024-2-21 21:36

xpmiemiezhou 发表于 2024-2-21 16:41
模版是规定死的，只能我那个模版，就是我要在你代码基础上增加一列统计该如何改？

你说模板是死的，那你还能修改模板格式？你还能增加列？
你把表数组结构都改变了，代码肯定要修改的。

ykcbf1100 · 发表于 2024-2-21 21:39

本帖最后由 ykcbf1100 于 2024-2-21 21:45 编辑

xpmiemiezhou 发表于 2024-2-21 14:32
谢谢！如果在每个表中责任人后面增加一列，代码要怎么修改才对？
Sub ykcbf() '//2024.2.21
Dim ...

数据范围改一下就行了。
为了增加通用性，现在责任人后面多插几列都不用改代码了。

ykcbf1100 · 发表于 2024-2-21 21:41

代码更改如下：

Sub ykcbf() '//2024.2.21
Dim arr, d
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook
Set sh = ws.Sheets("考核汇总")
For Each sht In ws.Sheets
If sht.Name <> sh.Name Then
With sht
fn = .Name
arr = .UsedRange
End With
p4 = IIf(InStr(fn, "自查"), "自查", "")
For i = 3 To UBound(arr)
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & p4
d(s) = arr(i, 6)
Next
End If
Next
ReDim brr(1 To d.Count, 1 To 7)
For Each k In d.keys
m = m + 1
b = Split(k, "|")
brr(m, 1) = m
brr(m, 2) = b(0)
brr(m, 3) = b(1)
brr(m, 4) = b(2)
brr(m, 5) = d(k)
brr(m, 7) = b(3)
Next
On Error Resume Next
With sh
.UsedRange.Offset(2).UnMerge
.UsedRange.Offset(2).Clear
With .[a3].Resize(m, 7)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.[a3].Resize(m, 7).Sort .[b3], 1
r = .Cells(Rows.Count, "a").End(xlUp).Row
brr = [{1,2, 6}]
Dim rng As Range
For i = r To 2 Step -1
Set rng = .Cells(i, "b")
Set Rng1 = rng.Offset(-1)
If rng = Rng1 Then
For x = 1 To UBound(brr)
.Cells(i, brr(x)).Offset(-1).Resize(2).Merge
Next
End If
Next
For i = 3 To r
Set rng = sh.Cells(i, "f")
If rng.MergeCells = True Then
n = n + 1
.Cells(i, 1) = n
s = 0
m = rng.MergeArea.Count
For x = 1 To m
s = s + sh.Cells(i + x - 1, "e")
Next
rng.Value = s
i = i + m - 1
Else
rng.Value = rng.Offset(, -1).Value
End If
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-2-21 21:47

修改后代码如下，增加代码通用性。

Sub ykcbf() '//2024.2.21
Dim arr, d
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook
Set sh = ws.Sheets("考核汇总")
For Each sht In ws.Sheets
If sht.Name <> sh.Name Then
With sht
fn = .Name
arr = .UsedRange
c = .Rows(2).Find("小计", , , , , 1).Column
End With
p4 = IIf(InStr(fn, "自查"), "自查", "")
For i = 3 To UBound(arr)
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & p4
d(s) = arr(i, c)
Next
End If
Next
ReDim brr(1 To d.Count, 1 To 7)
For Each k In d.keys
m = m + 1
b = Split(k, "|")
brr(m, 1) = m
brr(m, 2) = b(0)
brr(m, 3) = b(1)
brr(m, 4) = b(2)
brr(m, 5) = d(k)
brr(m, 7) = b(3)
Next
On Error Resume Next
With sh
.UsedRange.Offset(2).UnMerge
.UsedRange.Offset(2).Clear
With .[a3].Resize(m, 7)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.[a3].Resize(m, 7).Sort .[b3], 1
r = .Cells(Rows.Count, "a").End(xlUp).Row
brr = [{1,2, 6}]
Dim rng As Range
For i = r To 2 Step -1
Set rng = .Cells(i, "b")
Set Rng1 = rng.Offset(-1)
If rng = Rng1 Then
For x = 1 To UBound(brr)
.Cells(i, brr(x)).Offset(-1).Resize(2).Merge
Next
End If
Next
For i = 3 To r
Set rng = sh.Cells(i, "f")
If rng.MergeCells = True Then
n = n + 1
.Cells(i, 1) = n
s = 0
m = rng.MergeArea.Count
For x = 1 To m
s = s + sh.Cells(i + x - 1, "e")
Next
rng.Value = s
i = i + m - 1
Else
rng.Value = rng.Offset(, -1).Value
End If
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

shiruiqiang · 发表于 2024-2-21 21:52

本帖最后由 shiruiqiang 于 2024-2-21 21:55 编辑

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

如何使用代码实现 根据汇总表中B列部门名称，提取其他表中内容

如何使用代码实现根据汇总表中B列部门名称，提取其他表中内容