返回列表 上一主題 發帖

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

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2026-5-26 
1# 跳轉到 »
發表於 2021-4-28 15:04 | 顯示全部帖子
回復 1# f00l01

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

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2026-5-26 
2#
發表於 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 
最後登錄
2026-5-26 
3#
發表於 2021-5-17 12:06 | 顯示全部帖子
回復 1# f00l01


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

TOP

samwang

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

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2026-5-26 
8#
發表於 2021-6-7 08:12 | 顯示全部帖子
回復 13# 准提部林

字典隨取隨消, 減少佔用資源~~
>> 感謝准大分享，寫得精簡了，發現自己寫的太複雜，#12樓的寫法第1次看過，
真的不好理解，要好好的研究學習一下，謝謝。

TOP

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
返回列表 上一主題