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
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
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
比對後結果顯示在同一格儲存格，請測試看看，謝謝。
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
簡化一下#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
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
發表於 2021-4-28 14:53
| 
發表於 2021-6-7 13:02
| 
