Board logo

標題: 想找出與前一列重複的數字 [打印本頁]

作者: f00l01    時間: 2021-4-28 14:53     標題: 想找出與前一列重複的數字

各位先進好,

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

感謝大家的幫忙~
作者: samwang    時間: 2021-4-28 15:04

回復 1# f00l01

如果有範例會更容易理解,感謝。
作者: ML089    時間: 2021-4-28 19:46

[attach]33263[/attach]

是這樣嗎?
作者: f00l01    時間: 2021-5-17 09:00

回復 2# samwang


    範例檔案如上,看能不能從第二列之後都和前一列進行比對,謝謝大大提醒
作者: samwang    時間: 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
作者: samwang    時間: 2021-5-17 12:06

回復 1# f00l01


不好意思#5樓程式有問題,比對後的值有問題,請不用測試,謝謝
作者: samwang    時間: 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
作者: samwang    時間: 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
作者: samwang    時間: 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
作者: samwang    時間: 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
作者: f00l01    時間: 2021-5-24 09:50

好的,我再測試看看,謝謝大大
作者: 准提部林    時間: 2021-6-6 12:09

P欄設為文字格式~~

Sub TEST_A01()
Dim Arr, xD, i&, j%, T$, TT$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([m1], [a65536].End(xlUp))
For i = 1 To UBound(Arr)
For j = 1 To UBound(Arr, 2)
    T = Arr(i, j): xD(T & "/" & i) = 1
    If xD(T & "/" & i - 1) = 1 Then TT = TT & "," & T
Next j
    Arr(i, 1) = Mid(TT, 2): TT = ""
Next i
[p1].Resize(UBound(Arr)) = Arr
End Sub


'==============================
作者: 准提部林    時間: 2021-6-6 12:39

字典隨取隨消, 減少佔用資源~~

Sub TEST_A02()
Dim Arr, Brr, xD, i&, j%, TT$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([m1], [a65536].End(xlUp))
ReDim Brr(1 To UBound(Arr), 0)
For i = 2 To UBound(Arr)
    For j = 1 To UBound(Arr, 2)
        xD(Arr(i - 1, j) & "") = 1
    Next j
    For j = 1 To UBound(Arr, 2)
        If xD(Arr(i, j) & "") = 1 Then TT = TT & "," & Arr(i, j)
    Next j
    Brr(i, 0) = Mid(TT, 2): TT = "": xD.RemoveAll
Next i
[p1].Resize(UBound(Brr)) = Brr
End Sub


.==============================
作者: samwang    時間: 2021-6-7 08:12

回復 13# 准提部林

字典隨取隨消, 減少佔用資源~~
>> 感謝准大分享,寫得精簡了,發現自己寫的太複雜,#12樓的寫法第1次看過,
真的不好理解,要好好的研究學習一下,謝謝。
作者: 准提部林    時間: 2021-6-7 13:02

回復 14# samwang


12F

讓字典的key夾帶 i 值
當 i=1 時
將 xd(T & "/" & 1)=1 加入字典,
同時檢查 xd(T & "/" &  0) 是否在字典中, 因是第1行, 所以都為"空值",

當 i=2 時
將 xd(T & "/" & 2)=1 加入字典,
同時檢查 xd(T & "/" &  1) 是否在字典中, 因是第2行, 只要字典key帶1的, 即是上下行相同

類推~~
這方法讓所有數字都因行號不同而全部納入字典, 各自成為獨立的key值,
缺點: 字典會放太多資料
作者: Andy2483    時間: 2023-5-29 14:36

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

執行結果:
[attach]36465[/attach]


Option Explicit
Sub TEST()
Dim Brr, i&, j%, A$, Q$, TT$, T$
'↑宣告變數
Brr = Range([M1], [A65536].End(xlUp))
'↑令Brr變數是 二維陣列,以A~M欄儲存格值帶入陣列中
For i = 1 To UBound(Brr)
'↑設順迴圈i
   For j = 1 To UBound(Brr, 2)
   '↑設順迴圈j
      T = Brr(i, j)
      '↑令T變數是 迴圈Brr陣列值
      If InStr(A, "/" & T & "/") Then TT = TT & "," & T
      '↑如果A變數 包含了以(T變數在前後包夾"/"的新字串)??
      '↑令T變數納入TT變數後方,以逗點隔開,成為新字串
      '(當i=1時,A是初始值"",所以條件都不會成立)

      Q = Q & "/" & T & "/"
      '↑令Q變數收集該迴圈的陣列值,做為下一迴圈的A變數
   Next j
   Brr(i, 1) = Mid(TT, 2): TT = "": A = Q: Q = ""
   '↑令Brr陣列第1欄寫入符合條件的數字
Next i
[P1].Resize(UBound(Brr)) = Brr
'↑令Brr陣列值從[P1]開始寫入儲存格裡,超過此範圍的陣列值忽略
End Sub




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)