[已解决]求教一个关于查找统计的表

jiangnan329

如何将这个表后面的车间监舍小组分配依次填到个人小组表里，我要用个人小组表来打每个人的工牌，
试了很多办法都没法弄，自己也弄了些FIND的函数，一直在死循环，真心求教

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-16 15:52

1. Sub TIANSHU()
   
2.     Set D = CreateObject("scripting.dictionary")
   
3.     Dim crr(1 To 1000, 1 To 5)
   
4.     With Sheets("车间监舍小组分配")
   
5.         For k = 1 To 2
   
6.             r = IIf(k = 1, 1, 38)
   
7.             arr = .Cells(r, 1).CurrentRegion
   
8.             For i = 3 To UBound(arr)
   
9.                 For j = 2 To UBound(arr, 2)
   
10.                     xm = arr(i, j)
    
11.                     If Len(xm) > 0 Then
    
12.                         If Not D.exists(xm) Then
    
13.                             n = n + 1
    
14.                             D(xm) = n
    
15.                             crr(n, 1) = n
    
16.                             crr(n, 2) = xm
    
17.                             crr(n, 6 - k) = arr(i, 1) & arr(2, j)
    
18.                         Else
    
19.                             p = D(xm)
    
20.                             crr(p, 6 - k) = arr(i, 1) & arr(2, j)
    
21.                         End If
    
22.                     End If
    
23.         Next j, i, k
    
24.     End With
    
25.     With Sheets("个人小组表")
    
26.         .[a2:e1000] = ""
    
27.         .[a2].Resize(n, 5) = crr
    
28.     End With
    
29. End Sub

复制代码

跳转到最佳答案楼层

jiangnan329

大侠帮忙看看好吧

hupin6331

没看懂你的意思，个人小组表你都填好了，不知道你要引哪一列，你把需要填充的列涂色

grf1973

1. Sub TIANSHU()
   
2.     Set D = CreateObject("scripting.dictionary")
   
3.     Dim crr(1 To 1000, 1 To 5)
   
4.     With Sheets("车间监舍小组分配")
   
5.         For k = 1 To 2
   
6.             r = IIf(k = 1, 1, 38)
   
7.             arr = .Cells(r, 1).CurrentRegion
   
8.             For i = 3 To UBound(arr)
   
9.                 For j = 2 To UBound(arr, 2)
   
10.                     xm = arr(i, j)
    
11.                     If Len(xm) > 0 Then
    
12.                         If Not D.exists(xm) Then
    
13.                             n = n + 1
    
14.                             D(xm) = n
    
15.                             crr(n, 1) = n
    
16.                             crr(n, 2) = xm
    
17.                             crr(n, 6 - k) = arr(i, 1) & arr(2, j)
    
18.                         Else
    
19.                             p = D(xm)
    
20.                             crr(p, 6 - k) = arr(i, 1) & arr(2, j)
    
21.                         End If
    
22.                     End If
    
23.         Next j, i, k
    
24.     End With
    
25.     With Sheets("个人小组表")
    
26.         .[a2:e1000] = ""
    
27.         .[a2].Resize(n, 5) = crr
    
28.     End With
    
29. End Sub

复制代码

jiangnan329

谢谢你哦，基本上就是这个要求，不过你这比我想的还厉害，名字都可以自动统计出来，真的很强大，原来用的是字典工具，看来我的思路压根就错了，不过这阶段我目前是到不了
向大侠们多学习

雄鹰2013

Sub 分配() '雄鹰
Dim arr, brr, crr(1 To 1000, 1 To 5)
arr = Sheets("车间监舍小组分配").Range("a1").CurrentRegion
brr = Sheets("车间监舍小组分配").Range("a38").CurrentRegion
Set d = CreateObject("scripting.dictionary")
For i = 3 To UBound(arr)
     For j = 2 To UBound(arr, 2) '车间
         If arr(i, j) <> "" Then
            n = n + 1
            d(arr(i, j)) = n '姓名和行号对应
            crr(n, 1) = n
            crr(n, 2) = arr(i, j)
            crr(n, 5) = arr(i, 1) & arr(2, j)
         End If
     Next j
Next i
For i = 3 To UBound(brr) '宿舍
     For j = 2 To UBound(brr, 2)
        If brr(i, j) <> "" Then
           If d.exists(brr(i, j)) Then
              x = d(brr(i, j)) '出现过在姓名在行号
              crr(x, 4) = brr(i, 1) & brr(2, j)
           Else
              n = n + 1
              crr(n, 1) = n
              crr(n, 2) = brr(i, j)
              crr(n, 4) = brr(i, 1) & brr(2, j)
           End If
        End If
     Next j
Next i
Sheets("个人小组表").Range("g2").Resize(n, 5) = crr
End Sub