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

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

2^#

發表於 2021-4-28 15:04 | 只看該作者

回復 1# f00l01

如果有範例會更容易理解，感謝。

版主 Rank: 7 Rank: 7 Rank: 7

ML089

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

3^#

發表於 2021-4-28 19:46 | 只看該作者

想找出與前一列重複的數字.rar (6.28 KB)

是這樣嗎?

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

f00l01

中學生 Rank: 2

帖子: 17
主題: 6
精華: 0
積分: 63
點名: 0
作業系統: Windows 10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
註冊時間: 2021-1-7
最後登錄: 2021-7-22

4^#

發表於 2021-5-17 09:00 | 只看該作者

回復 2# samwang

範例檔案如上，看能不能從第二列之後都和前一列進行比對，謝謝大大提醒

Files (5).zip (6.89 KB)

檔案範例

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

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

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

6^#

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

回復 1# f00l01

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

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

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

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

8^#

發表於 2021-5-17 15:36 | 只看該作者

本帖最後由 samwang 於 2021-5-17 15:47 編輯

簡化一下#7樓程式，請測試看看，謝謝。
寫得不好，不知其他大大有無其他寫法可分享，感謝。

Sub test2()
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
          M = xD(T & "")
         If M > 0 Then N = N + 1: Ar(1, N) = xD(T & "")
         xD(T & "") = T: xD2(T & "") = T
      Else
          M = xD2(T & "")
         If M > 0 Then N = N + 1: Ar(1, N) = xD2(T & "")
         xD(T & "") = T: xD2(T & "") = T
      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

擷取.PNG (13.66 KB)

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

9^#

發表於 2021-5-20 08:02 | 只看該作者

本帖最後由 samwang 於 2021-5-20 08:07 編輯

簡化一下#8樓程式，不好意思，後學思慮不夠細心，一直再修改簡化，請再測試看看，謝謝。
Sub test3()
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
         M = xD(T & ""): xD2(T & "") = T
         If M > 0 Then N = N + 1: Ar(1, N) = xD(T & "")
      Else
         M = xD2(T & ""): xD(T & "") = T
         If M > 0 Then N = N + 1: Ar(1, N) = xD2(T & "")
      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

擷取.PNG (16.88 KB)

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

10^#

發表於 2021-5-20 08:31 | 只看該作者

回復 1# f00l01

比對後結果顯示在同一格儲存格，請測試看看，謝謝。
Sub 結果顯示同一格()
Dim Arr, Ar(), xD, xD2, T, i&, C%
Set xD = CreateObject("Scripting.Dictionary")
Set xD2 = CreateObject("Scripting.Dictionary")
Arr = Range("a1").CurrentRegion
ReDim Ar(1 To UBound(Arr), 0)
For i = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
      T = Arr(i, j)
      If i = 1 Then xD(T & "") = T: GoTo 99
      If C = 0 Then
         M = xD(T & ""): xD2(T & "") = T
         If M > 0 Then Ar(i, 0) = Ar(i, 0) & "," & xD(T & "")
      Else
         M = xD2(T & ""): xD(T & "") = T
         If M > 0 Then Ar(i, 0) = Ar(i, 0) & "," & xD2(T & "")
      End If
99: Next
If i > 1 Then
      If C = 0 Then
         Ar(i, 0) = Mid(Ar(i, 0), 2): C = 1: Set xD = Nothing
         Set xD = CreateObject("Scripting.Dictionary")
      Else
         Ar(i, 0) = Mid(Ar(i, 0), 2): C = 0: Set xD2 = Nothing
         Set xD2 = CreateObject("Scripting.Dictionary")
      End If
End If
Next
Range("N1").Resize(UBound(Arr)) = Ar
End Sub

擷取1.PNG (15.12 KB)