- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
24#
發表於 2023-3-30 16:01
| 只看該作者
本帖最後由 Andy2483 於 2023-3-30 16:28 編輯
回復 23# coafort
謝謝論壇,謝謝前輩
後學模擬情境,學習VBA儲存格集.觸發與字典的方案如下,請前輩參考
 Xl0000797_20230330_3.zip (34.73 KB)
執行前:
輸入後執行結果:
工作表模組:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Row < 3 Or .Value = "" Or .Count > 1 Then Exit Sub
If .Column Mod 5 <> 1 Then Exit Sub
Cancel = True
Call 變字色_多個同股名
If Y(.Value & "|") > 1 Then Y(.Value).Interior.ColorIndex = 4
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Row < 3 Or .Count > 1 Then Exit Sub
If .Column Mod 5 <> 0 Then Exit Sub
Call 變字色_多個同股名
If Y(.Offset(0, -4) & "|") > 1 Then
Y(.Offset(0, -4) & "").Interior.ColorIndex = 4
Application.EnableEvents = False
Y(.Offset(0, -4) & "/").Value = .Value
Application.EnableEvents = True
Application.Goto Y(.Offset(0, -4) & "/")
End If
End With
End Sub
Module1:
Option Explicit
Public Y
Sub 變字色_多個同股名()
Dim Brr, Crr, C&, i&, X&, xR, R&, T, V, Z, Ad
Set Y = CreateObject("Scripting.Dictionary")
ActiveSheet.UsedRange.Offset(2).Font.ColorIndex = 1
ActiveSheet.UsedRange.Offset(2).Interior.ColorIndex = xlNone
Brr = ActiveSheet.UsedRange
Set Y(1) = [B1]
For C = 1 To UBound(Brr, 2) Step 5
For R = 3 To UBound(Brr)
Y(Brr(R, C) & "|") = Y(Brr(R, C) & "|") + 1
If Y(Brr(R, C) & "|") = 1 Then
Set Y(Brr(R, C)) = Cells(R, C)
Set Y(Brr(R, C) & "/") = Cells(R, C + 4)
GoTo PASS
End If
If Y(Brr(R, C) & "|") = 2 Then
Set Y(1) = Union(Y(1), Y(Brr(R, C)))
End If
Set Y(1) = Union(Y(1), Cells(R, C))
Set Y(Brr(R, C)) = Union(Y(Brr(R, C)), Cells(R, C))
Set Y(Brr(R, C) & "/") = Union(Y(Brr(R, C) & "/"), Cells(R, C + 4))
PASS:
Next
Next
Y(1).Font.ColorIndex = 5
End Sub |
|
