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

xpmiemiezhou

ykcbf1100 发表于 2024-2-22 11:47
代码如下，按自选部门查询。

查询部门可以修改成J列一列吗？就像图片中一样，或者就是J2到J41单元格每个单元格可以输入需要查询部门，按照我输入的部门从上到下按顺序匹配部门提取文件，如果J2列有的部门，在上级考核和自查考核工作表中没有，就跳过继续匹配和提取后面的部门数据。还有一个问题就是 我新增一个别的工作表后，代码就出错了，能不受新增工作表限制吗？

ykcbf1100

xpmiemiezhou 发表于 2024-2-22 21:15
查询部门可以修改成J列一列吗？就像图片中一样，或者就是J2到J41单元格每个单元格可以输入需要查询部门， ...

改好了。。。

ykcbf1100

2024.2.23代码更新。

1. Sub ykcbf()   '//2024.2.23
   
2.     Dim arr, d, zr
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("考核汇总")
   
9.     With sh
   
10.         r = .Cells(Rows.Count, "j").End(3).Row
    
11.         zrr = .Range("j2:j" & r)
    
12.     End With
    
13.     For i = 1 To UBound(zrr)
    
14.         k = zrr(i, 1)
    
15.         d1(k) = ""
    
16.     Next
    
17.     On Error Resume Next
    
18.     For Each sht In ws.Sheets
    
19.         If sht.Name <> sh.Name Then
    
20.             If IsArray(sht.UsedRange) Then
    
21.                 With sht
    
22.                     fn = .Name
    
23.                     arr = .UsedRange
    
24.                     c = .Rows(2).Find("小计", , , , , 1).Column
    
25.                 End With
    
26.                 p4 = IIf(InStr(fn, "自查"), "自查", "")
    
27.                 For i = 3 To UBound(arr)
    
28.                     If d1.exists(arr(i, 2)) Then
    
29.                         s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5) & "|" & p4
    
30.                         d(s) = arr(i, c)
    
31.                     End If
    
32.                 Next
    
33.             End If
    
34.         End If
    
35.     Next
    
36.     ReDim brr(1 To d.Count, 1 To 8)
    
37.     For Each k In d.keys
    
38.         m = m + 1
    
39.         b = Split(k, "|")
    
40.         brr(m, 1) = m
    
41.         brr(m, 2) = b(0)
    
42.         brr(m, 3) = b(1)
    
43.         brr(m, 4) = b(2)
    
44.         brr(m, 5) = b(3)
    
45.         brr(m, 6) = d(k)
    
46.         brr(m, 8) = b(4)
    
47.     Next
    
48.     With sh
    
49.         .[a3:h10000].UnMerge
    
50.         .[a3:h10000].Clear
    
51.         With .[a3].Resize(m, 8)
    
52.             .Value = brr
    
53.             .Borders.LineStyle = 1
    
54.             .HorizontalAlignment = xlCenter
    
55.             .VerticalAlignment = xlCenter
    
56.         End With
    
57.         .[a3].Resize(m, 8).Sort .[b3], 1
    
58.         zr = Array(1, 2, 7)
    
59.         Call hb(3, 2, zr)
    
60.         Call hbsum(3, 4, 6, 7)
    
61.     End With
    
62.     Set d = Nothing
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "OK！"
    
65. End Sub
    

复制代码

xpmiemiezhou

ykcbf1100 发表于 2024-2-23 07:44
2024.2.23代码更新。

老大，还是不对哦，要按查询部门的部门顺序提取，查询部门第一个是部门2就提取部门2的排在第一，B列部门名称顺序要跟J列部门顺序一样。辛苦大哥，向你致敬！

ykcbf1100

xpmiemiezhou 发表于 2024-2-23 09:51
老大，还是不对哦，要按查询部门的部门顺序提取，查询部门第一个是部门2就提取部门2的排在第一，B列部门 ...

不要要求那么高了。
不再跟进。

xpmiemiezhou

ykcbf1100 发表于 2024-2-23 09:58
不要要求那么高了。
不再跟进。

谢谢啦！！！

saghj

牛逼！

xpmiemiezhou

shiruiqiang 发表于 2024-2-20 14:29
按照你的要求，可以少写几句

根据你写的代码，我自己试着修改了一下我需要更改的地方，但是新增几个工作表我要另做他用时，这个代码就会出现13错误，能不能帮忙修改一下，我新增的表格可以做其他事情，不影响原来汇总表汇总原有两个分表数据

shiruiqiang

xpmiemiezhou 发表于 2024-2-23 17:45
根据你写的代码，我自己试着修改了一下我需要更改的地方，但是新增几个工作表我要另做他用时，这个代码就 ...

xpmiemiezhou

shiruiqiang 发表于 2024-2-23 18:29

谢谢大师，很好用！