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

shiruiqiang · 发表于 2024-2-20 22:43

上附件，多模拟数据

ykcbf1100 · 发表于 2024-2-21 07:35

xpmiemiezhou 发表于 2024-2-20 22:01
有些部门多几行数据就统计不出来了

你不是自己已经设置好表的结构了吗？你求助时可没说有些部门会多几行数据。

xpmiemiezhou · 发表于 2024-2-21 12:24

ykcbf1100 发表于 2024-2-21 07:35
你不是自己已经设置好表的结构了吗？你求助时可没说有些部门会多几行数据。

之前没有考虑到有些多有些少

半百 · 发表于 2024-2-21 12:33

xpmiemiezhou 发表于 2024-2-20 22:15
要是在金额前面增加一列类型就统计不出来了，代码要如何修改？代码能附上说明吗？这样方便我后期学习和修 ...

已修改。。。

xpmiemiezhou · 发表于 2024-2-21 12:45

shiruiqiang 发表于 2024-2-20 22:42
n=n+5-dic(aa).count删除就行

n=n+5-dic(aa).count删除解决了问题，请问高手，如果在每个表里增加一列代码该如何修改？附件中我增加了类型这一列就统计不出来了。

xpmiemiezhou · 发表于 2024-2-21 13:02

半百发表于 2024-2-21 12:33
已修改。。。

谢谢！！！！！！

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

xpmiemiezhou 发表于 2024-2-20 22:01
有些部门多几行数据就统计不出来了

代码重写了，汇总表第3行以下全部自动生成。

ykcbf1100 · 发表于 2024-2-21 13:14

代码以附件为准。

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
r = .Cells(.Rows.Count, "a").End(xlUp).Row
fn = .Name
arr = .[a1].Resize(r, 5)
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, 5)
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

复制代码

xpmiemiezhou · 发表于 2024-2-21 14:32

ykcbf1100 发表于 2024-2-21 13:13
代码重写了，汇总表第3行以下全部自动生成。

谢谢！如果在每个表中责任人后面增加一列，代码要怎么修改才对？
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
            r = .Cells(.Rows.Count, "a").End(xlUp).Row
            fn = .Name
            arr = .[a1].Resize(r, 5)
         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, 5)
         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

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

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
重排序的列

复制代码

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

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

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