[已解决]VBA对比异样数据

jk0932

如附件所示：
在sheet“原始数据”里给出了货物及价格；
在sheet“检查项目”里给出了，多个发货商，种类及价格。
现在需要在sheet“检查项目”里核查出相同种类但价格不同的发货商，提取结果到Sheet“结果”
谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2015-6-7 08:06

1. Sub Macro1()
   
2. Dim ar, br, cr, d, i&, s&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Sheet1.Range("a1").CurrentRegion
   
5. br = Sheet2.Range("a1").CurrentRegion
   
6. ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
   
7. Sheet3.Activate
   
8. ActiveSheet.UsedRange.ClearContents
   
9. For i = 1 To UBound(ar)
   
10. d(ar(i, 1)) = ar(i, 2)
    
11. Next
    
12. For i = 1 To UBound(br)
    
13.     If br(i, 3) <> d(br(i, 2)) Then
    
14.         s = s + 1
    
15.         For j = 1 To UBound(br, 2)
    
16.             cr(s, j) = br(i, j)
    
17.         Next
    
18.     End If
    
19. Next
    
20. If s Then [a1].Resize(s, UBound(cr, 2)) = cr
    
21. End Sub

复制代码

跳转到最佳答案楼层

冥王

1. Sub demo()
   
2.     Dim arr, brr(1 To 30000, 1 To 3), dic As Object
   
3.     Dim iRow%, i%, j%, k%
   
4.     With ThisWorkbook
   
5.         Set dic = CreateObject("Scripting.Dictionary")
   
6.         arr = .Sheets("原始数据").Range("A1").CurrentRegion
   
7.         For i = LBound(arr, 1) To UBound(arr, 1)
   
8.             dic(arr(i, 1)) = arr(i, 2)
   
9.         Next
   
10.         ar = .Sheets("检查项目").Range("A2:C" & .Sheets("检查项目").Cells(Rows.Count, 1).End(xlUp).Row)
    
11.         For j = LBound(ar, 1) To UBound(ar, 1)
    
12.             If ar(j, 3) <> dic(ar(j, 2)) Then
    
13.                 k = k + 1
    
14.                 brr(k, 1) = ar(j, 1)
    
15.                 brr(k, 2) = ar(j, 2)
    
16.                 brr(k, 3) = ar(j, 3)
    
17.             End If
    
18.         Next
    
19.         .Sheets("结果").UsedRange.Offset(1, 0).Clear
    
20.         .Sheets("结果").Range("A2").Resize(k, 3) = brr
    
21.     End With
    
22. End Sub

复制代码

dsmch

1. Sub Macro1()
   
2. Dim ar, br, cr, d, i&, s&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Sheet1.Range("a1").CurrentRegion
   
5. br = Sheet2.Range("a1").CurrentRegion
   
6. ReDim cr(1 To UBound(br), 1 To UBound(br, 2))
   
7. Sheet3.Activate
   
8. ActiveSheet.UsedRange.ClearContents
   
9. For i = 1 To UBound(ar)
   
10. d(ar(i, 1)) = ar(i, 2)
    
11. Next
    
12. For i = 1 To UBound(br)
    
13.     If br(i, 3) <> d(br(i, 2)) Then
    
14.         s = s + 1
    
15.         For j = 1 To UBound(br, 2)
    
16.             cr(s, j) = br(i, j)
    
17.         Next
    
18.     End If
    
19. Next
    
20. If s Then [a1].Resize(s, UBound(cr, 2)) = cr
    
21. End Sub

复制代码