- 帖子
- 2834
- 主題
- 10
- 精華
- 0
- 積分
- 2890
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-27
|
17#
發表於 2022-1-13 16:36
| 只看該作者
建議用16樓samwang 大的方法...用兩次迴圈~~
以下兩種代碼僅供參考, 難以理解, 不想多做解釋了!
Sub TEST_A1()
Dim Arr, Brr, Crr, xD, S As Worksheet, SN$, T$, U&, i&, j%, k&, N&, P%
Set xD = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To 30000, 1 To 4): Crr = Brr
For Each S In Sheets
Arr = S.[a1].CurrentRegion: SN = S.Name
If Not SN Like "*#日" Then GoTo x01
For i = 2 To UBound(Arr)
T = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 3)
k = k + 1: Crr(k, 4) = SN: U = xD(T): P = 0
If U > 0 Then N = N + 1: P = 1
For j = 1 To 4
If j < 4 Then Crr(k, j) = Arr(i, j)
If U > 0 Then Brr(N, j) = Crr(U, j): xD(T) = -1
If U < 0 Or P = 1 Then Brr(N + 1, j) = Crr(k, j)
Next j
If xD(T) = 0 Then xD(T) = k Else N = N + 1
i01: Next i
x01: Next
With Sheets("總表")
.[a1].CurrentRegion.Offset(1).ClearContents
If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub
'============================
Sub TEST_A2()
Dim Arr, Brr, Crr, xD, S As Worksheet, SN$, T$, i&, j%, k&, N&
Set xD = CreateObject("Scripting.Dictionary")
ReDim Brr(1 To 30000, 1 To 4): Crr = Brr
For Each S In Sheets
Arr = S.[a1].CurrentRegion: SN = S.Name
If Not SN Like "*#日" Then GoTo x01
For i = 2 To UBound(Arr)
k = k + 1: Crr(k, 4) = SN: T = "": U = 0
For j = 1 To 3
T = T & "|" & Arr(i, j)
Crr(k, j) = Arr(i, j)
Next j
If xD(T) = 0 Then xD(T) = k: GoTo i01
If xD(T) > 0 Then U = xD(T): N = N + 1: xD(T) = -1
For j = 1 To 4
If U > 0 Then Brr(N, j) = Crr(U, j)
Brr(N + 1, j) = Crr(k, j)
Next
N = N + 1
i01: Next i
x01: Next
With Sheets("總表")
.[a1].CurrentRegion.Offset(1).ClearContents
If N > 0 Then .[a2].Resize(N, 4) = Brr
End With
End Sub
'====================================== |
|
發表於 2022-1-11 13:00
| 
