12
返回列表 上一主題 發帖

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

f00l01

帖子
17 
主題
6 
精華
0 
積分
63 
點名
0  
作業系統
Windows 10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
註冊時間
2021-1-7 
最後登錄
2021-7-22 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2021-4-28 14:53 | 只看該作者

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

各位先進好，

請問是否能列出每一列與上一列相比有重複的數字？

感謝大家的幫忙~
收藏 分享

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-12-18 
2#
發表於 2021-4-28 15:04 | 只看該作者
回復 1# f00l01

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

TOP

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 三鍵輸入公式

TOP

f00l01

帖子
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)

檔案範例

TOP

samwang

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

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2024-12-18 
6#
發表於 2021-5-17 12:06 | 只看該作者
回復 1# f00l01


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

TOP

samwang

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

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

擷取.PNG

TOP

samwang

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

擷取.PNG

TOP

samwang

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

擷取1.PNG

TOP

        靜思自在 : 要比誰更受誰．不要比誰更怕誰。
12
返回列表 上一主題