loyyee

回復 10# dechiuan999

您好 程式可以用了!
但如果資料改變如附檔且上千筆會出現錯誤，勞駕您幫忙看看。

數值比對2.rar (65.37 KB)

下載次數: 16

2011-10-9 16:02

Hsieh

回復 11# loyyee
並非資料筆數問題
是如果沒有和條件的資料就會造成Resize出錯

1. Sub Ex()
   
2. Dim Ay(), Ay1()
   
3. Set d = CreateObject("Scripting.dictionary")
   
4. Set d1 = CreateObject("Scripting.dictionary")
   
5. [E6].CurrentRegion.Offset(1, 0) = ""
   
6. [I1].CurrentRegion.Offset(1, 0) = ""
   
7. 
   
8. ar1 = [A1].CurrentRegion.Columns(1).Value
   
9. ar2 = [A1].CurrentRegion.Columns(2).Value
   
10. ar = Array(ar1, ar2)
    
11. For i = 0 To 1
    
12. For Each a In ar(i)
    
13.    Select Case i
    
14.    Case 0
    
15.    If a <> "" Then d(a) = d(a) + 1
    
16.    Case 1
    
17.    If a <> "" Then d1(a) = d1(a) + 1
    
18.    End Select
    
19. Next
    
20. Next
    
21. dic = Array(d, d1)
    
22. For i = 0 To 1
    
23. For Each ky In dic(i).keys
    
24. p = IIf(i = 0, 1, 0)
    
25.    If dic(p).exists(ky) = False Then
    
26.    ReDim Preserve Ay(s)
    
27.    Ay(s) = ky
    
28.    s = s + 1
    
29.    End If
    
30.    If dic(i)(ky) > 1 Then
    
31.    ReDim Preserve Ay1(k)
    
32.    Ay1(k) = ky
    
33.    k = k + 1
    
34.    End If
    
35. Next
    
36. If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
    
37. If k > 0 Then Cells(7, 5 + i).Resize(k, 1) = Application.Transpose(Ay1): k = 0: Erase Ay1
    
38. Next
    
39. End Sub

複製代碼

loyyee

回復 12# Hsieh

可以用了，Hsieh感謝您指點!

fyo00241

感謝各大大的分享,,雖然不能下載附件也學習了

loyyee

回復 12# Hsieh

If s > 0 Then Cells(2, 9 + i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay 要改成
If s > 0 Then Cells(2, 10 - i).Resize(s, 1) = Application.Transpose(Ay): s = 0: Erase Ay
   
欠缺數值欄位才會對應到。

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:

下載 (126.73 KB)

2023-6-15 15:10

執行結果:

下載 (136.08 KB)

2023-6-15 15:11

Option Explicit
Sub TEST()
Dim Brr, Va&, Vb&, Z, Q, i&, Ra&, Rb&, M&, Ta$, Tb$
[E7:F65536,I2:J65536].ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Brr = Intersect([A1].CurrentRegion, [A:B])
For i = 1 To UBound(Brr)
   Ta = Brr(i, 1): Tb = Brr(i, 2): Brr(i, 1) = "": Brr(i, 2) = ""
   If Ta = "" Then GoTo i01 Else Va = Z(Ta)
   If Va = 1 Then
      Ra = Ra + 1
      Brr(Ra, 1) = Ta
      M = IIf(M < Ra, Ra, M)
      Else:
         Z(Ta) = 1
   End If
i01: If Tb = "" Then GoTo i02 Else Vb = Z("|" & Tb)
   If Vb = 1 Then
      Rb = Rb + 1
      Brr(Rb, 2) = Tb
      M = IIf(M < Rb, Rb, M)
      Else
         Z("|" & Tb) = 1
   End If
i02: Next
If M > 0 Then [E7].Resize(M, 2) = Brr
ReDim Brr(1 To UBound(Brr), 1 To 2)
Ra = 0: Rb = 0: M = 0
For Each Q In Z.KEYS
   If InStr(Q, "|") = 0 Then
      If Z.Exists("|" & Q) = Empty Then
         Rb = Rb + 1
         Brr(Rb, 2) = Q
      End If
      ElseIf Z.Exists(Mid(Q, 2)) = Empty Then
         Ra = Ra + 1
         Brr(Ra, 1) = Mid(Q, 2)
   End If
   If M < Ra Then M = Ra
   If M < Rb Then M = Rb
Next
If M > 0 Then [I2].Resize(M, 2) = Brr
Set Z = Nothing: Erase Brr
End Sub