想找出與前一列重複的數字

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-4-29

7^# 跳轉到 »

發表於 2021-5-17 12:28 | 只看該作者

回復 1# f00l01

程式已更新如下，請測試看看，謝謝。

Sub test1()
Dim Arr, xD, xD2, Ar(), T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
For i = 1 To UBound(Arr)
ReDim Ar(1 To 1, 1 To UBound(Arr, 2))
For j = 1 To UBound(Arr, 2)
      T = Arr(i, j)
      If i = 1 Then xD(T & "") = T: GoTo 99
      If C = 0 Then
         If xD.Exists(T & "") Then
            N = N + 1: xD2(T & "") = T: Ar(1, N) = xD(T & "")
         Else
            xD(T & "") = T: xD2(T & "") = T
         End If
      Else
         If xD2.Exists(T & "") Then
            N = N + 1: xD(T & "") = T: Ar(1, N) = xD2(T & "")
         Else
            xD(T & "") = T: xD2(T & "") = T
         End If
      End If
99: Next
If i > 1 Then
      If C = 0 Then
         Cells(i, 15).Resize(1, N) = Ar
         C = 1: Erase Ar: Set xD = Nothing: N = 0
         Set xD = CreateObject("Scripting.Dictionary")
      Else
         Cells(i, 15).Resize(1, N) = Ar
         C = 0: Erase Ar: Set xD2 = Nothing: N = 0
         Set xD2 = CreateObject("Scripting.Dictionary")
      End If
End If
Next
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-4-29

6^#

發表於 2021-5-17 12:06 | 只看該作者

回復 1# f00l01

不好意思#5樓程式有問題，比對後的值有問題，請不用測試，謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-4-29

5^#

發表於 2021-5-17 10:48 | 只看該作者

回復 4# f00l01

請測試看看，謝謝
Sub test()
Dim Arr, xD, xD2, Ar(), T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
For i = 1 To UBound(Arr)
ReDim Ar(1 To 1, 1 To UBound(Arr, 2))
For j = 1 To UBound(Arr, 2)
      T = Arr(i, j)
      If C = 0 Then
         If xD.Exists(T & "") Then
            N = N + 1: xD2(T & "") = T
            Ar(1, N) = xD(Arr(i, j) & "")
         Else
            xD(T & "") = T
            xD2(T & "") = T
         End If
      Else
         If xD2.Exists(T & "") Then
            N = N + 1: xD(T & "") = T
            Ar(1, N) = xD2(Arr(i, j) & "")
         Else
            xD(T & "") = T
            xD2(T & "") = T
         End If
      End If
Next
If i > 1 Then
      If C = 0 Then
         Cells(i, 15).Resize(1, N) = Ar
         C = 1: Erase Ar: Set xD = Nothing: N = 0
         Set xD = CreateObject("Scripting.Dictionary")
      Else
         Cells(i, 15).Resize(1, N) = Ar
         C = 0: Erase Ar: Set xD2 = Nothing: N = 0
         Set xD2 = CreateObject("Scripting.Dictionary")
      End If
End If
Next
End Sub

TOP

f00l01