Sub test()
Dim xD, Arr, Brr(), i&, Ar, a&, b$, j%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([F1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 1 To UBound(Arr)
If xD.Exists(Arr(i, 4) & "") Then
m = m + 1
列 = xD(Arr(i, 4) & "")
Brr(列, 3) = Brr(列, 3) & "_" & m
Brr(列, 4) = Brr(列, 4) & "_" & Arr(i, 1)
Else
m = m + 1
xD(Arr(i, 4) & "") = i
Brr(m, 2) = Arr(i, 4)
Brr(m, 3) = m
Brr(m, 4) = Arr(i, 1)
End If
Next
For i = 1 To UBound(Arr)
For ib = 1 To UBound(Brr)
pos = InStr(Brr(ib, 3), "_")
If pos > 0 And Arr(i, 4) = Brr(ib, 2) Then
Ar = Split(Brr(ib, 3), "_")
For j = 0 To UBound(Ar)
a = Split(Brr(ib, 3), "_")(j)
b = Split(Brr(ib, 4), "_")(j)
If i <> a Then
If Cells(i, 8) = "" Then
Cells(i, 8) = "D" & a
Cells(i, 9) = b
Rows(i).EntireRow.Interior.ColorIndex = 6
Else
Cells(i, 8) = Cells(i, 8) & "," & "D" & a
Cells(i, 9) = Cells(i, 9) & "," & b
End If
End If
Next
End If
Next
Next
End Sub作者: 准提部林 時間: 2021-3-6 11:28
Sub TEST_A01()
Dim Arr, xD, i&, T$, T1$, T2$, SR, S, xR As Range, xU As Range
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是 字典
With Range([J1], [A65536].End(3))
'↑以下是關於本表A~J欄儲存格的程序
.EntireRow.Interior.ColorIndex = xlNone
'↑令該區域全列底色是無色
.Offset(1, 7).ClearContents
'↑令該區域往下偏移1列,往右7欄區域儲存格清除內容
[H1:J1] = Array("重覆位置", "重覆次數", "對應場名稱")
'↑令[H1:J1]儲存格寫入列標題
Arr = .Cells
'↑令Arr變數是 二維陣列,以該區域儲存格值帶入陣列中
End With
For i = 2 To UBound(Arr)
'↑設順迴圈
T = Arr(i, 4): T2 = Arr(i, 6)
'↑令字串變數裝入陣列值
xD(T) = Trim(xD(T) & " " & i)
'↑令T變數當key,item是 自身連接空白字元,再連接i變數,所組成的新字串
If T2 <> "" Then xD(T & "/y") = T2
'↑如果T2變數不是空字元!就令T變數連接"/y"組成的新字串當key,
'item是T2變數,納入xD字典中
Next i
For i = 2 To UBound(Arr)
'↑設順迴圈
SR = Split(xD(Arr(i, 4) & ""), " ")
'↑令SR變數是一維陣列:以陣列第4欄值提取xD字典item,
'再以空白字元分割成為一維陣列
If UBound(SR) <= 0 Then GoTo i01
'↑如果SR陣列最後一個索引號<=0,就跳到標示i0位置繼續執行
T1 = "": T2 = "": Set xR = Range("D" & i)
'↑令T1,T2變數是 空字元,令xR變數是 D欄i列儲存格
For Each S In SR
'↑設逐項迴圈!令S變數是SR陣列值之一
If Val(S) <> i Then
'↑如果S變數轉數值後 與i變數不同
T1 = T1 & "," & "D" & S
'↑令T1變數是 自身連接逗號,再連接"D",最後連接S變數成新字串
T2 = T2 & "," & Arr(S, 1)
'↑令T2變數是 自身連接逗號,再連接S變數列第1欄Arr陣列值
End If
Next S
Arr(i, 6) = xD(Arr(i, 4) & "/y")
'↑令迴圈列第6欄Arr陣列值是 迴圈列第6欄Arr陣列值連接"/y"成的新字串,查
'查xD字典回傳的item值
Arr(i, 8) = Mid(T1, 2)
'↑令迴圈列第8欄Arr陣列值是 T1變數取第2字以後的全部字串
Arr(i, 9) = UBound(SR) + 1
'↑令迴圈列第9欄Arr陣列值是 SR陣列最大索引號+1
Arr(i, 10) = Mid(T2, 2)
'↑令迴圈列第10欄Arr陣列值是 T2變數取第2字以後的全部字串
If xU Is Nothing Then Set xU = xR Else Set xU = Union(xU, xR)
'↑如果xU變數是空的,就令xU變數是xR變數,否則就將xR變數納入xU儲存格集裡
i01: Next i
[a1].Resize(UBound(Arr), UBound(Arr, 2)) = Arr
'↑令Arr陣列從[A1]開始寫入範圍儲存格中
If Not xU Is Nothing Then xU.EntireRow.Interior.ColorIndex = 6
'↑如果xU變數不是空的,就令該xU儲存格集所在的列整列底色為黃色
End Sub