[已解决]求助！如何追加人员信息

kawashaki8899

根据“学号”，将【追加信息】里的J列至U列的数据自动对应到【信息总库】的CA列至CL列,达到现在这个效果

因为原表有几千条人员信息，请用VB实现，{:25:}

最佳答案

月排行榜 / 总排行榜

dsmch

2015-12-28 15:11

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, n&, sht As Worksheet
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set sht = Sheets("信息总库")
   
5. arr = sht.Range("b5").CurrentRegion
   
6. brr = Sheets("追加信息").Range("a13").CurrentRegion
   
7. For i = 2 To UBound(brr)
   
8.     d(brr(i, 5)) = i
   
9. Next
   
10. For i = 2 To UBound(arr)
    
11.     If d.exists(arr(i, 3)) Then
    
12.         n = d(arr(i, 3))
    
13.         For j = 10 To 21
    
14.             sht.Cells(i + 4, j + 69) = brr(n, j)
    
15.         Next
    
16.     End If
    
17. Next
    
18. End Sub

复制代码

跳转到最佳答案楼层

baksy

附件

kawashaki8899

baksy 发表于 2015-12-25 14:39
附件

非常感谢你这么快就回复!{:25:}

但你这是用函数公式调用的形式，

我是想要用VB的形式，因为实际数据量很大，用函数复制公式很麻烦，容易不小心搞错！

求用VB写段代码，用一个“按钮”实现

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j%, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. [ca6:cl20000] = ""
   
5. arr = Range("b5").CurrentRegion
   
6. brr = Sheets("追加信息").Range("a13").CurrentRegion
   
7. ReDim crr(1 To UBound(arr) - 1, 1 To 12)
   
8. For i = 2 To UBound(brr)
   
9.     d(brr(i, 5)) = i
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12.     If d.exists(arr(i, 3)) Then
    
13.         n = d(arr(i, 3))
    
14.         For j = 10 To 21
    
15.             crr(i - 1, j - 9) = brr(n, j)
    
16.         Next
    
17.     End If
    
18. Next
    
19. Range("ca6").Resize(UBound(crr), UBound(crr, 2)) = crr
    
20. End Sub

复制代码

dsmch

………………

kawashaki8899

dsmch 发表于 2015-12-25 16:19
………………

{:25:}
先谢谢了，回去看看效果

kawashaki8899

dsmch 发表于 2015-12-25 16:19
………………

再次感谢！
测试后发现一个问题，按动“追加数据按钮”后，对应学号的数据已经能写到“信息总库”对应人员，但同时把“这次没在追加数据表中出现人员的CA列至CL列原来的内容”给删除了

实际上“追加数据”表会多次更新，每次更新点“追加数据按钮”后把当前“追加数据”表中的数据更新到“信息总库”对应人员处

可能我之前没表达清楚，不好意思！
请抽空帮我再看看好吗？谢谢

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. [ca6:cl20000] = ""
   
5. arr = Range("b5").CurrentRegion
   
6. brr = Sheets("追加信息").Range("a13").CurrentRegion
   
7. For i = 2 To UBound(brr)
   
8.     d(brr(i, 5)) = i
   
9. Next
   
10. For i = 2 To UBound(arr)
    
11.     If d.exists(arr(i, 3)) Then
    
12.         n = d(arr(i, 3))
    
13.         For j = 10 To 21
    
14.             Cells(i + 4, j + 69) = brr(n, j)
    
15.         Next
    
16.     End If
    
17. Next
    
18. End Sub

复制代码

dsmch

或这样……

1. Sub Macro1()
   
2. Dim arr, brr, crr(1 To 12), d, i&, j%, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. [ca6:cl20000] = ""
   
5. arr = Range("b5").CurrentRegion
   
6. brr = Sheets("追加信息").Range("a13").CurrentRegion
   
7. For i = 2 To UBound(brr)
   
8.     d(brr(i, 5)) = i
   
9. Next
   
10. For i = 2 To UBound(arr)
    
11.     If d.exists(arr(i, 3)) Then
    
12.         n = d(arr(i, 3))
    
13.         For j = 10 To 21
    
14.             crr(j - 9) = brr(n, j)
    
15.         Next
    
16.         Cells(i + 4, "ca").Resize(1, 12) = crr
    
17.     End If
    
18. Next
    
19. End Sub

复制代码

kawashaki8899

dsmch 发表于 2015-12-28 10:44
或这样……

这么快就给了2个方案，太好了，我去试试！，谢谢！谢谢！！