[已解决]求助各位高人，如何从不同的工作表寻值

zsl_asa

情况请见附件，目标工作表有A-Z个人员吧，总共有值一到值十个项目，这些人员和项目分散到各个分表中，如何用公式在目标工作表中实现对应项目归集啊，请教各位大神了！谢谢！
1.rar (2.37 KB, 下载次数: 8)

2016-1-14 11:46 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sry660

2016-1-14 12:59

1. Sub 归集()
   
2. Dim arr, i&, j&, Sh As Worksheet, x, brr, d
   
3. arr = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. For Each Sh In Worksheets
   
7.     If Sh.Name <> "目标" Then
   
8.         With Sh
   
9.             brr = .[a1].CurrentRegion
   
10.             For i = 2 To UBound(brr)
    
11.                 For j = 2 To UBound(brr, 2)
    
12.                     x = brr(i, 1) & brr(1, j)
    
13.                     d(x) = d(x) + brr(i, j)
    
14.                 Next
    
15.             Next
    
16.         End With
    
17.     End If
    
18. Next
    
19. For i = 2 To UBound(arr)
    
20.     For j = 2 To UBound(arr, 2)
    
21.         x = arr(i, 1) & arr(1, j)
    
22.         If d.exists(x) Then
    
23.             arr(i, j) = d(x)
    
24.         End If
    
25.     Next
    
26. Next
    
27. [b2:k100].ClearContents
    
28. [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
29. End Sub

复制代码

跳转到最佳答案楼层

sry660

1. Sub 归集()
   
2. Dim arr, i&, j&, Sh As Worksheet, x, brr, d
   
3. arr = [a1].CurrentRegion
   
4. Set d = CreateObject("scripting.dictionary")
   
5. ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
6. For Each Sh In Worksheets
   
7.     If Sh.Name <> "目标" Then
   
8.         With Sh
   
9.             brr = .[a1].CurrentRegion
   
10.             For i = 2 To UBound(brr)
    
11.                 For j = 2 To UBound(brr, 2)
    
12.                     x = brr(i, 1) & brr(1, j)
    
13.                     d(x) = d(x) + brr(i, j)
    
14.                 Next
    
15.             Next
    
16.         End With
    
17.     End If
    
18. Next
    
19. For i = 2 To UBound(arr)
    
20.     For j = 2 To UBound(arr, 2)
    
21.         x = arr(i, 1) & arr(1, j)
    
22.         If d.exists(x) Then
    
23.             arr(i, j) = d(x)
    
24.         End If
    
25.     Next
    
26. Next
    
27. [b2:k100].ClearContents
    
28. [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
29. End Sub

复制代码

zsl_asa

sry660 发表于 2016-1-14 12:59

牛逼啊，感谢 了！