[已解决]跨表条件显示值-请看附件-在线等

likeblue

详情看附件，先谢谢了，实际数据量有点大，稍微考虑一下运行速度。谢谢了

跨表条件取值.rar (7.56 KB, 下载次数: 21)

2014-3-4 11:02 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-3-4 12:09

likeblue 发表于 2014-3-4 11:53
能否来些注释，我不是想直接用，我是想学。

1. 
   
2. Sub test()
   
3. 
   
4.   Dim arr(), i&, j%, k%, re(), cnt&, rq
   
5. 'Sheet1的A4单元格数据区域赋值给数组arr
   
6.   arr = Sheets("Sheet1").Range("A4").CurrentRegion.Value
   
7. '定义re数组的区域为 arr上标*6（考虑最多的可能是全部日期全部对上的可能）
   
8.   ReDim re(1 To UBound(arr) * 6, 1 To 1)
   
9. '将sheet2的B3单元格值赋给rq变量，避免反复读取单元格的值
   
10.   rq = Sheets("sheet2").[b3].Value
    
11. '从数组第一行开始循环
    
12.   For i = 1 To UBound(arr)
    
13. '检查数组的第一列和第二列是否和rq一致
    
14.     For j = 1 To 2
    
15. 
    
16.       If arr(i, j) = rq Then
    
17. '如果一致则将后三列中非空单元格放入数组re，同时计数变量递增1
    
18.         For k = 3 To 5
    
19. 
    
20.           If arr(i, k) <> "" Then
    
21. 
    
22.             cnt = cnt + 1
    
23. 
    
24.             re(cnt, 1) = arr(i, k)
    
25. 
    
26.           End If
    
27. 
    
28.         Next
    
29. 
    
30.       End If
    
31. 
    
32.     Next
    
33. 
    
34.   Next
    
35. 
    
36.   Dim rng As Range
    
37. 
    
38.   Set rng = Sheets("sheet2").[b6]
    
39. '列标题
    
40.   rng = "类别"
    
41. '将数组填入单元格区域
    
42.   rng.Offset(1, 0).Resize(cnt, 1) = re
    
43. 
    
44. End Sub

复制代码

跳转到最佳答案楼层

baksy

B7单元格复制以下公式，三键回车( 先按住 shift、ctrl 两个键，然后敲enter键 )、下拉。
=INDEX(Sheet1!C$1:C$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1)))&INDEX(Sheet1!D$1:D$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1)))&INDEX(Sheet1!E$1:E$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1)))

likeblue

baksy 发表于 2014-3-4 11:27
B7单元格复制以下公式，三键回车( 先按住 shift、ctrl 两个键，然后敲enter键 )、下拉。
=INDEX(Sheet1!C$ ...

先谢谢，已经达到要求，但如果下拉超过统计数字后，会显示错误符号。
能否利用vba?

baksy

likeblue 发表于 2014-3-4 11:34
先谢谢，已经达到要求，但如果下拉超过统计数字后，会显示错误符号。
能否利用vba?

追加判断
=IFERROR(INDEX(Sheet1!C$1:C$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1)))&INDEX(Sheet1!D$1:D$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1)))&INDEX(Sheet1!E$1:E$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),ROW(A$5:A$16)),ROW(A1))),"")

likeblue

baksy 发表于 2014-3-4 11:39
追加判断
=IFERROR(INDEX(Sheet1!C$1:C$16,SMALL(IF(((Sheet1!A$5:A$16=B$3)+(Sheet1!B$5:B$16=B$3)),RO ...

再次谢谢，你的答案符合要求，但我想要用VBA。

xdragon

1. 
   
2. Sub test()
   
3.   Dim arr(), i&, j%, k%, re(), cnt&, rq
   
4.   arr = Sheets("Sheet1").Range("A4").CurrentRegion.Value
   
5.   ReDim re(1 To UBound(arr) * 6, 1 To 1)
   
6.   rq = Sheets("sheet2").[b3].Value
   
7.   For i = 1 To UBound(arr)
   
8.     For j = 1 To 2
   
9.       If arr(i, j) = rq Then
   
10.         For k = 3 To 5
    
11.           If arr(i, k) <> "" Then
    
12.             cnt = cnt + 1
    
13.             re(cnt, 1) = arr(i, k)
    
14.           End If
    
15.         Next
    
16.       End If
    
17.     Next
    
18.   Next
    
19.   Dim rng As Range
    
20.   Set rng = Sheets("sheet2").[b6]
    
21.   rng = "类别"
    
22.   rng.Offset(1, 0).Resize(cnt, 1) = re
    
23. End Sub

复制代码

likeblue

xdragon 发表于 2014-3-4 11:44

能否来些注释，我不是想直接用，我是想学。

xdragon

likeblue 发表于 2014-3-4 11:53
能否来些注释，我不是想直接用，我是想学。

1. 
   
2. Sub test()
   
3. 
   
4.   Dim arr(), i&, j%, k%, re(), cnt&, rq
   
5. 'Sheet1的A4单元格数据区域赋值给数组arr
   
6.   arr = Sheets("Sheet1").Range("A4").CurrentRegion.Value
   
7. '定义re数组的区域为 arr上标*6（考虑最多的可能是全部日期全部对上的可能）
   
8.   ReDim re(1 To UBound(arr) * 6, 1 To 1)
   
9. '将sheet2的B3单元格值赋给rq变量，避免反复读取单元格的值
   
10.   rq = Sheets("sheet2").[b3].Value
    
11. '从数组第一行开始循环
    
12.   For i = 1 To UBound(arr)
    
13. '检查数组的第一列和第二列是否和rq一致
    
14.     For j = 1 To 2
    
15. 
    
16.       If arr(i, j) = rq Then
    
17. '如果一致则将后三列中非空单元格放入数组re，同时计数变量递增1
    
18.         For k = 3 To 5
    
19. 
    
20.           If arr(i, k) <> "" Then
    
21. 
    
22.             cnt = cnt + 1
    
23. 
    
24.             re(cnt, 1) = arr(i, k)
    
25. 
    
26.           End If
    
27. 
    
28.         Next
    
29. 
    
30.       End If
    
31. 
    
32.     Next
    
33. 
    
34.   Next
    
35. 
    
36.   Dim rng As Range
    
37. 
    
38.   Set rng = Sheets("sheet2").[b6]
    
39. '列标题
    
40.   rng = "类别"
    
41. '将数组填入单元格区域
    
42.   rng.Offset(1, 0).Resize(cnt, 1) = re
    
43. 
    
44. End Sub

复制代码

likeblue

xdragon 发表于 2014-3-4 12:09

非常感谢~~~~

likeblue

xdragon 发表于 2014-3-4 12:09

好像有一些问题。然后我稍微修改了一下基础数据，麻烦在看一下


跨表条件取值2.rar (15.63 KB, 下载次数: 12)

2014-3-4 16:19 上传

点击文件名下载附件