- 帖子
- 2799
- 主題
- 10
- 精華
- 0
- 積分
- 2855
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-4-28
|
１＞Ａ區／Ｂ區同時存在，剔除
２＞Ａ區有多筆相同，只取一筆（Ｂ區同理）
３＞右側結果每筆之間不留空白行，兩區各自上下區存放
寫得有點複雜，自行逐行參酌：
 Xl0000283.rar (214.58 KB)
Sub TEST()
Dim Arr, Brr, xD, i&, j%, U&, V&, N&, T1$, T2$, T3$
[O4:AA20000].Clear
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([M4], Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 13)
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4): T3 = Arr(i, 8)
If T1 = "座標" Then V = i - 1: GoTo 101
If T1 = "" Or T2 = "" Or T3 = "" Then GoTo 101
U = xD(T1 & T2 & T3)
If U = 0 Then xD(T1 & T2 & T3) = i: GoTo 101
If U > 0 And U <= V Then xD(T1 & T2 & T3) = -1
101: Next i
For i = 1 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4): T3 = Arr(i, 8)
U = xD(T1 & T2 & T3)
If T1 = "座標" And N > 0 Then N = V
If T1 = "座標" Or U = i Then
N = N + 1
For j = 1 To 13: Brr(N, j) = Arr(i, j): Next
End If
Next i
With [O4:AA4].Resize(UBound(Brr))
.NumberFormatLocal = "@"
.Value = Brr
.Borders.LineStyle = 1
End With
End Sub
|
|
發表於 2018-10-23 20:11
| 