对比增加表和明细表的工号,将增加表有而明细表没有的数据写入明细表

mcgswy

对比<增加表>和<明细表>的工号,将<增加表>有而<明细表>没有的数据写入<明细表>表头与其对应的单元格.哪位大神指点一下.

不知道为什么

用字典     

mcgswy

不知道为什么 发表于 2018-8-17 16:36
用字典

大神,我的基本代码已经编写了,能不能劳烦您,看下代码要如何修改.

不知道为什么

mcgswy 发表于 2018-8-17 16:41
大神,我的基本代码已经编写了,能不能劳烦您,看下代码要如何修改.

你那代买只判断了一个 工号

hefuqing

1. Sub d4()
   
2. Dim crr()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. r = Sheets("增加").[A65536].End(xlUp).Row
   
5. arr = Sheets("增加").Range("A3:f" & r)
   
6. 
   
7. r1 = Sheets("明细").[A65536].End(xlUp).Row
   
8. brr = Sheets("明细").Range("A3:A" & r1)
   
9. 
   
10. For i = 1 To UBound(brr)
    
11. d(brr(i, 1)) = ""
    
12. Next
    
13. 
    
14. For i = 1 To UBound(arr)
    
15. If Not d.Exists(arr(i, 1)) Then
    
16. n = n + 1
    
17. ReDim Preserve crr(1 To 6, 1 To n)
    
18. For k = 1 To 6
    
19. crr(k, n) = arr(i, k)
    
20. Next
    
21. End If
    
22. Next
    
23. 
    
24. Sheets("明细").Cells(r1 + 1, 1).Resize(n, 6) = Application.Transpose(crr)
    
25. End Sub

复制代码

mcgswy

hefuqing 发表于 2018-8-17 17:20

老师,执行后Sheets("明细").Cells(r1 + 1, 1).Resize(n, 6) = Application.Transpose(crr)报错,无效的过程调用或参数

hefuqing

我可以的 我把附件给你了 你试试

hefuqing

加了判定条件 再试试

1. Sub 录入()
   
2. Dim crr()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. r = Sheets("增加").[A65536].End(xlUp).Row
   
5. arr = Sheets("增加").Range("A3:f" & r)
   
6. 
   
7. r1 = Sheets("明细").[A65536].End(xlUp).Row
   
8. brr = Sheets("明细").Range("A3:A" & r1)
   
9. 
   
10. For i = 1 To UBound(brr)
    
11. d(brr(i, 1)) = ""
    
12. Next
    
13. 
    
14. For i = 1 To UBound(arr)
    
15. If Not d.Exists(arr(i, 1)) Then
    
16. n = n + 1
    
17. ReDim Preserve crr(1 To 6, 1 To n)
    
18. For k = 1 To 6
    
19. crr(k, n) = arr(i, k)
    
20. Next
    
21. End If
    
22. Next
    
23. If n > 0 Then
    
24. Sheets("明细").Cells(r1 + 1, 1).Resize(n, 6) = Application.Transpose(crr)
    
25. MsgBox "成功加入" & n & "条"
    
26. Else
    
27. MsgBox "没有新的员工"
    
28. End If
    
29. End Sub

复制代码

LMY123

如果是新增的工号，则标题行相同，数据自动复制

1. 'http://club.excelhome.net/thread-1221723-1-1.html
   
2. Sub 选择相同列字段内容进行考贝_新增工号()
   
3.     Dim d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     With Sheets("明细")
   
7.         arr = .[a1].CurrentRegion
   
8.         l = UBound(arr, 2)
   
9.         For i = 1 To l
   
10.             d(arr(1, i)) = i
    
11.         Next
    
12.          For i = 3 To UBound(arr)
    
13.             d1(arr(i, 1)) = i
    
14.         Next
    
15.         arr = Sheets("增加").[a1].CurrentRegion
    
16.         h = UBound(arr) - 1
    
17.         ReDim brr(1 To h, 1 To l)
    
18.         
    
19.         For i = 3 To UBound(arr)
    
20.             For j = 1 To UBound(arr, 2)
    
21.                 If d.exists(arr(1, j)) Then
    
22.                     If Not d1.exists(arr(i, 1)) Then
    
23.                         brr(i - 2, d(arr(1, j))) = arr(i, j)
    
24.                     End If
    
25.                 End If
    
26.             Next
    
27.         Next
    
28.         .[a65536].End(3).Offset(1, 0).Resize(h, l) = brr
    
29.     End With
    
30. End Sub

复制代码

mcgswy

非常感谢各位老师的帮忙