[已解决]求大神帮忙如何使用vba对数据匹配和条件输出的问题

531tommy

sheet2中已有的日期、型号和类型与sheet1相同时，存量已sheet1的为准；
sheet2中不存在sheet1的日期、型号和类型的添加到sheet2空白row+1添加
用公式可以组&组合日期型号和类型三个，但转换VBA我就不懂了

最佳答案

月排行榜 / 总排行榜

lisongmei

2021-9-16 03:01

1. Option Explicit
   
2. Sub Modify_sheet2() 'sheet2中已有的日期、型号和类型与sheet1相同时，存量已sheet1的为准
   
3. Dim arr, arr2
   
4. Dim dic
   
5. Dim i, j As Integer
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. arr = Sheet1.Range("a1:d" & Sheet1.[a100000].End(xlUp).Row)
   
8. arr2 = Sheet2.Range("a1:d" & Sheet2.[a100000].End(xlUp).Row)
   
9. Sheet2.Range("d2:d1000").ClearContents
   
10. For i = 2 To UBound(arr)
    
11.     dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = arr(i, 4)
    
12. Next
    
13. For j = 2 To UBound(arr2)
    
14.     If dic.Exists(arr2(j, 1) & arr2(j, 2) & arr2(j, 3)) Then
    
15.         arr2(j, 4) = dic(arr2(j, 1) & arr2(j, 2) & arr2(j, 3))
    
16.     End If
    
17. Next
    
18. Sheet2.Range("d1").Resize(UBound(arr2), 1) = Application.Index(arr2, , 4)
    
19. End Sub
    
20. 
    
21. Sub add_sheet1() 'sheet2中不存在sheet1的日期、型号和类型的添加到sheet2空白row+1添加
    
22. Dim arr, arr2
    
23. Dim arr3(1 To 1000, 1 To 4)
    
24. Dim dic
    
25. Dim i, j, k As Integer
    
26. k = 0
    
27. Set dic = CreateObject("scripting.dictionary")
    
28. arr = Sheet1.Range("a1:d" & Sheet1.[a100000].End(xlUp).Row)
    
29. arr2 = Sheet2.Range("a1:d" & Sheet2.[a100000].End(xlUp).Row)
    
30. For i = 2 To UBound(arr2)
    
31.     dic(arr2(i, 1) & arr2(i, 2) & arr2(i, 3)) = arr2(i, 4)
    
32. Next
    
33. For j = 2 To UBound(arr)
    
34.     If Not dic.Exists(arr(j, 1) & arr(j, 2) & arr(j, 3)) Then
    
35.         k = k + 1
    
36.         arr3(k, 1) = arr(j, 1)
    
37.         arr3(k, 2) = arr(j, 2)
    
38.         arr3(k, 3) = arr(j, 3)
    
39.         arr3(k, 4) = arr(j, 4)
    
40.     End If
    
41. Next
    
42. Sheet2.Range("a10000").End(xlUp).Offset(1, 0).Resize(k, 4) = arr3
    
43. End Sub
    

复制代码

跳转到最佳答案楼层

lisongmei

1. Option Explicit
   
2. Sub Modify_sheet2() 'sheet2中已有的日期、型号和类型与sheet1相同时，存量已sheet1的为准
   
3. Dim arr, arr2
   
4. Dim dic
   
5. Dim i, j As Integer
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. arr = Sheet1.Range("a1:d" & Sheet1.[a100000].End(xlUp).Row)
   
8. arr2 = Sheet2.Range("a1:d" & Sheet2.[a100000].End(xlUp).Row)
   
9. Sheet2.Range("d2:d1000").ClearContents
   
10. For i = 2 To UBound(arr)
    
11.     dic(arr(i, 1) & arr(i, 2) & arr(i, 3)) = arr(i, 4)
    
12. Next
    
13. For j = 2 To UBound(arr2)
    
14.     If dic.Exists(arr2(j, 1) & arr2(j, 2) & arr2(j, 3)) Then
    
15.         arr2(j, 4) = dic(arr2(j, 1) & arr2(j, 2) & arr2(j, 3))
    
16.     End If
    
17. Next
    
18. Sheet2.Range("d1").Resize(UBound(arr2), 1) = Application.Index(arr2, , 4)
    
19. End Sub
    
20. 
    
21. Sub add_sheet1() 'sheet2中不存在sheet1的日期、型号和类型的添加到sheet2空白row+1添加
    
22. Dim arr, arr2
    
23. Dim arr3(1 To 1000, 1 To 4)
    
24. Dim dic
    
25. Dim i, j, k As Integer
    
26. k = 0
    
27. Set dic = CreateObject("scripting.dictionary")
    
28. arr = Sheet1.Range("a1:d" & Sheet1.[a100000].End(xlUp).Row)
    
29. arr2 = Sheet2.Range("a1:d" & Sheet2.[a100000].End(xlUp).Row)
    
30. For i = 2 To UBound(arr2)
    
31.     dic(arr2(i, 1) & arr2(i, 2) & arr2(i, 3)) = arr2(i, 4)
    
32. Next
    
33. For j = 2 To UBound(arr)
    
34.     If Not dic.Exists(arr(j, 1) & arr(j, 2) & arr(j, 3)) Then
    
35.         k = k + 1
    
36.         arr3(k, 1) = arr(j, 1)
    
37.         arr3(k, 2) = arr(j, 2)
    
38.         arr3(k, 3) = arr(j, 3)
    
39.         arr3(k, 4) = arr(j, 4)
    
40.     End If
    
41. Next
    
42. Sheet2.Range("a10000").End(xlUp).Offset(1, 0).Resize(k, 4) = arr3
    
43. End Sub
    

复制代码

531tommy

531tommy

lisongmei 发表于 2021-9-16 03:01

Sub add_sheet1()
操作中，要是sheet2数据与sheet1数据一致时，写入数据的
Sheet2.Range("A65536").End(xlUp).Offset(1, 0).Resize(k, 4) = arr3出现错误提示，需要如何解决

lisongmei

531tommy 发表于 2021-9-16 08:50
Sub add_sheet1()
操作中，要是sheet2数据与sheet1数据一致时，写入数据的
Sheet2.Range("A65536").En ...

代码最前面加句 on error resume next 应可解决这个问题