多表查询某一条数据后将其汇总到一张表格

碣石山人

目前学习字典：
就是下面的需求，应该不难，但我转置学习差不多了，但这样汇总还需要大家指点！

不知道为什么

不明白这样的需求为什么要用字典呢？不要把简单的事情复杂 啊

碣石山人

不知道为什么 发表于 2019-3-9 22:35
不明白这样的需求为什么要用字典呢？不要把简单的事情复杂 啊

数组也行啊，函数我会的。如果搞复杂了没法理解，我现在是小白，但总要举一反三吧？
从简单的学习可以容易些，还请大师指教！多谢！

不知道为什么

碣石山人 发表于 2019-3-9 22:44
数组也行啊，函数我会的。如果搞复杂了没法理解，我现在是小白，但总要举一反三吧？
从简单的学习可以容 ...

查询的代码

1. Option Base 1
   
2. Sub chaxun()
   
3.     Dim arr, brr(20, 23)
   
4.     Dim sht As Worksheet
   
5.     ms = Sheet13.[d2].Value
   
6.     For Each sht In Worksheets
   
7.         If InStr(sht.Name, "月") Then
   
8.             arr = sht.Range("a4:y" & sht.Cells(sht.Rows.Count, 2).End(3).Row)
   
9.             For i = 1 To UBound(arr)
   
10.                 If arr(i, 2) = ms Then
    
11.                     X = X + 1
    
12.                     brr(X, 1) = sht.Name
    
13.                     For j = 4 To UBound(arr, 2)
    
14.                         brr(X, j - 2) = arr(i, j)
    
15.                     Next j
    
16.                     Exit For
    
17.                 End If
    
18.             Next i
    
19.         End If
    
20.     Next
    
21.     With Sheet13
    
22.         If X > 0 Then
    
23.             .UsedRange.Offset(4, 0).ClearContents
    
24.             .[a5].Resize(X, 23) = brr
    
25.         End If
    
26.     End With
    
27. End Sub
    

复制代码

不知道为什么

碣石山人 发表于 2019-3-9 22:44
数组也行啊，函数我会的。如果搞复杂了没法理解，我现在是小白，但总要举一反三吧？
从简单的学习可以容 ...

   

不知道为什么

碣石山人 发表于 2019-3-9 22:44
数组也行啊，函数我会的。如果搞复杂了没法理解，我现在是小白，但总要举一反三吧？
从简单的学习可以容 ...

    代码审核，图片参考

不知道为什么

附件供测试
数据查询-R.zip (24.58 KB, 下载次数: 29)

2019-3-9 22:51 上传

点击文件名下载附件

lsc900707

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address = "$D$2" Then
   
3.         Dim brr(1 To 9999, 1 To 23)
   
4.         For Each sht In Sheets
   
5.             If InStr(sht.Name, "月") Then
   
6.                 arr = sht.[a3].CurrentRegion
   
7.                 For i = 2 To UBound(arr)
   
8.                     If arr(i, 2) = Target Then
   
9.                         m = m + 1
   
10.                         brr(m, 1) = sht.Name
    
11.                         For j = 2 To 23
    
12.                             brr(m, j) = arr(i, j + 2)
    
13.                         Next
    
14.                     End If
    
15.                 Next
    
16.             End If
    
17.         Next
    
18.         If m Then
    
19.             [a4].CurrentRegion.Offset(1).ClearContents
    
20.             [a5].Resize(m, 23) = brr
    
21.         End If
    
22.     End If
    
23. End Sub

复制代码

lsc900707

再来一个字典的，不过a列要先填写好呀;

1. Sub gj23w98()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     For Each sht In Sheets
   
4.         If InStr(sht.Name, "月") Then
   
5.             arr = sht.[a3].CurrentRegion
   
6.             For i = 2 To UBound(arr)
   
7.                 For j = 4 To UBound(arr, 2)
   
8.                     s = arr(i, 2) & sht.Name & arr(1, j)
   
9.                      d(s) = arr(i, j)
   
10.                 Next
    
11.             Next
    
12.         End If
    
13.     Next
    
14.     brr = [a4].CurrentRegion
    
15.     For i = 2 To UBound(brr)
    
16.         For j = 2 To UBound(brr, 2)
    
17.             s = [d2] & brr(i, 1) & brr(1, j)
    
18.             If d.exists(s) Then brr(i, j) = d(s)
    
19.         Next
    
20.     Next
    
21.     [a4].CurrentRegion = brr
    
22. End Sub

复制代码

lsc900707

参考测试附件：