麻辣家族討論版版 - Powered by Discuz! Board

標題: 儲存各取得焦點後某一欄位變色 [打印本頁]

作者: coafort 時間: 2024-2-1 13:26 標題: 儲存各取得焦點後某一欄位變色

請問各位大大
比方點了AR212欄位
AG212底色會變
要怎設計呢
謝謝

作者: Andy2483 時間: 2024-2-1 14:23

回復 1# coafort
工作表模組下植入:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Replace(Split(.Address, "$")(1), ":", "") = "AR" Then
   Me.UsedRange.EntireColumn.Interior.ColorIndex = xlNone
   '↑令本表使用格的整欄底色為無色
   .Offset(, -11).Interior.ColorIndex = 6
   '↑令一開始選取格是AR欄儲存格範圍的左側11欄儲存格底色是黃色
End If
End With
End Sub

作者: coafort 時間: 2024-2-1 17:36

本帖最後由 coafort 於 2024-2-1 17:38 編輯

回復 coafort
工作表模組下植入:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Targ ...
Andy2483 發表於 2024-2-1 14:23

請問大大
用了之後原來的顏色都沒了
謝謝

作者: Andy2483 時間: 2024-2-1 18:29

本帖最後由 Andy2483 於 2024-2-1 19:05 編輯

回復 3# coafort

工作表模組下植入:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Replace(Split(.Address, "$")(1), ":", "") = "AR" Then
   .Offset(, -11).EntireColumn.Interior.ColorIndex = xlNone
   '↑令AG欄整欄底色為無色
   .Offset(, -11).Interior.ColorIndex = 6
   '↑令一開始選取格是AR欄儲存格範圍的左側11欄儲存格底色是黃色
End If
End With
End Sub

作者: coafort 時間: 2024-2-1 18:51

回復 coafort

回復 1# coafort
工作表模組下植入:
Option Explicit
Private Sub Worksheet_Sel ...
Andy2483 發表於 2024-2-1 18:29

謝謝大大
請問有辦法保留原有欄的顏色嗎？

作者: Andy2483 時間: 2024-2-1 18:57

本帖最後由 Andy2483 於 2024-2-1 19:07 編輯

回復 5# coafort

工作表模組下植入:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Replace(Split(.Address, "$")(1), ":", "") = "AR" Then
.Offset(, -11).Interior.ColorIndex = 6
'↑令一開始選取格是AR欄儲存格範圍的左側11欄儲存格底色是黃色
End If
End With
End Sub

作者: coafort 時間: 2024-2-1 19:18

回復 coafort

工作表模組下植入:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Ta ...
Andy2483 發表於 2024-2-1 18:57

報告大大
離開後黃底不會消失耶
謝謝大大

作者: Andy2483 時間: 2024-2-1 19:54

回復 7# coafort

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a as Range
With Target
For Each a in Intersect([AG:AG],Me.UsedRange)
   If a.interior.Colorindex=6 Then a.interior.colorindex=xlnone
Next
If Replace(Split(.Address, "$")(1), ":", "") = "AR" Then
   .Offset(, -11).Interior.ColorIndex = 6
   '↑令一開始選取格是AR欄儲存格範圍的左側11欄儲存格底色是黃色
End If
End With
End Sub

作者: quickfixer 時間: 2024-2-1 23:31

https://stackoverflow.com/questions/58282085/change-cell-color-when-it-selected-and-back-original-color-after-leaving-it

樓主要的應該是這個功能

作者: quickfixer 時間: 2024-2-2 07:54

本帖最後由 quickfixer 於 2024-2-2 07:56 編輯

回復 9# quickfixer

該位作者的程式碼有2個問題

程式執行中,無法修改顏色
程式開頭加入if, cc 看要不要用某個cell代替
cc = "顏色可修改"
If cc = "顏色可修改" Then Exit Sub

選取欄位會把無關的列數全部放入陣列,也不能選整個工作表,程式會lag超久
簡單加個限制,可選取的列上限100,欄上限26,這要看電腦效能修改

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
Static OldColor As Variant
Dim rw As Long, cl As Long

'cc = "顏色可修改"
If cc = "顏色可修改" Then Exit Sub
If Target.Columns.Count > 26 Then Exit Sub

If Not rngcolor Is Nothing Then
      If IsArray(OldColor) Then
         On Error GoTo NoRestore
         For rw = 1 To rngcolor.Rows.Count
            For cl = 1 To rngcolor.Columns.Count
                  If IsEmpty(OldColor(rw, cl)) Then
                     rngcolor.Cells(rw, cl).Interior.ColorIndex = xlNone
                  Else
                     rngcolor.Cells(rw, cl).Interior.Color = OldColor(rw, cl)
                  End If
            Next
         Next
         On Error GoTo 0
      Else
         If IsEmpty(OldColor) Then
            rngcolor.Interior.ColorIndex = xlNone
         Else
            rngcolor.Interior.Color = OldColor
         End If
      End If
End If
NoRestore:
On Error GoTo 0

If Target.Rows.Count > 100 Then nr = 100 Else nr = Target.Rows.Count
Set rngcolor = Target.Resize(nr)

ReDim OldColor(1 To nr, 1 To Target.Columns.Count)
For rw = 1 To nr
      For cl = 1 To Target.Columns.Count
         If Target.Cells(rw, cl).Interior.ColorIndex = xlNone Then
            OldColor(rw, cl) = Empty
         Else
            OldColor(rw, cl) = Target.Cells(rw, cl).Interior.Color
         End If
      Next
Next
rngcolor.Interior.Color = vbYellow
End Sub

作者: coafort 時間: 2024-2-2 08:06

回復 coafort

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
D ...
Andy2483 發表於 2024-2-1 19:54

真是太感謝大大
可以了
請問大大
如果我要精確一點
焦點在AR212至AR219及AX212至AZ219
變色的地方是AJ212至AJ219
請問該怎麼做呢？謝謝大大

作者: coafort 時間: 2024-2-2 08:08

回復 quickfixer

該位作者的程式碼有2個問題

程式執行中,無法修改顏色
程式開頭加入if, cc ...
quickfixer 發表於 2024-2-2 07:54

謝謝大大
執行後出現錯誤

作者: quickfixer 時間: 2024-2-2 08:16

本帖最後由 quickfixer 於 2024-2-2 08:23 編輯

回復 12# coafort

Option Explicit 那行刪掉或是加上 dim cc as string,nr as integer

作者: Andy2483 時間: 2024-2-2 09:05

回復 11# coafort
請前輩試試看以下效果是否適合
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a As Range, b As Range, c As Range
With Target
Set b = [AJ212:AJ219]
Set c = [AR212:AR219,AX212:AZ219]
For Each a In b
If a.Interior.ColorIndex = 6 Then a.Interior.ColorIndex = xlNone
Next
Set c = Intersect(.Cells, c)
If Not c Is Nothing Then Intersect(c.EntireRow, b).Interior.ColorIndex = 6
End With
End Sub

作者: coafort 時間: 2024-2-2 10:21

回復 coafort

Option Explicit 那行刪掉或是加上 dim cc as string,nr as integer
quickfixer 發表於 2024-2-2 08:16

變成點選的變色@@
不是我要的
依然感謝大大

作者: coafort 時間: 2024-2-2 10:21

回復 coafort
請前輩試試看以下效果是否適合
Option Explicit
Private Sub Worksheet_SelectionChange ...
Andy2483 發表於 2024-2-2 09:05

哈哈
感謝大大
可以了耶
讚讚讚

作者: Andy2483 時間: 2024-2-2 11:20

本帖最後由 Andy2483 於 2024-2-2 11:22 編輯

回復 16# coafort
謝謝論壇,謝謝前輩讓後學學到很多知識
以下是後學針對[AJ212:AJ219]如果原來有底色,但是選取[AR212:AR219,AX212:AZ219]之後變黃色,移開之後能恢復原來底色的方案
原來底色:
[attach]37395[/attach]

選取後變黃色:
[attach]37396[/attach]

移開後恢復原色:
[attach]37397[/attach]

Option Explicit
Dim Brr
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim b As Range, c As Range, i&
With Target
Set b = [AJ212:AJ219]: Set c = [AR212:AR219,AX212:AZ219]
If Not IsArray(Brr) Then Brr = b: For i = 1 To UBound(Brr): Brr(i, 1) = b(i).Interior.ColorIndex: Next
Set c = Intersect(.Cells, c)
If Not c Is Nothing Then
   Intersect(c.EntireRow, b).Interior.ColorIndex = 6
   Else
   For i = 1 To UBound(Brr)
      If b(i).Interior.ColorIndex = 6 Then b(i).Interior.ColorIndex = Brr(i, 1)
   Next
   Brr = Empty
End If
End With
End Sub

作者: coafort 時間: 2024-2-2 11:48

回復 coafort
謝謝論壇,謝謝前輩讓後學學到很多知識
以下是後學針對[AJ212:AJ219]如果原來有底色,但是選 ...
Andy2483 發表於 2024-2-2 11:20

報告大大
出現錯誤
細細大大

作者: Andy2483 時間: 2024-2-2 13:37

回復 18# coafort

是色差?還是偵錯?
再藉此帖學習RGB,學習方案如下:

Option Explicit
Dim Brr
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim b As Range, c As Range, i&
With Target
Set b = [AJ212:AJ219]: Set c = [AR212:AR219,AX212:AZ219]
If Not IsArray(Brr) Then
   ReDim Brr(1 To b.Count, 1 To 3)
   For i = 1 To UBound(Brr)
      Brr(i, 1) = b(i).Interior.Color Mod 256
      Brr(i, 2) = b(i).Interior.Color \ 256 Mod 256
      Brr(i, 3) = b(i).Interior.Color \ 256 ^ 2 Mod 256
   Next
End If
Set c = Intersect(.Cells, c)
If Not c Is Nothing Then
   Intersect(c.EntireRow, b).Interior.Color = RGB(255, 255, 0) '黃色
   Else
   For i = 1 To UBound(Brr)
      If b(i).Interior.Color = RGB(255, 255, 0) Then b(i).Interior.Color = RGB(Brr(i, 1), Brr(i, 2), Brr(i, 3))
   Next
   Brr = Empty
End If
End With
End Sub

作者: coafort 時間: 2024-2-2 13:54

本帖最後由 coafort 於 2024-2-2 14:02 編輯

[attach]37398[/attach]

回復 coafort

是色差?還是偵錯?
再藉此帖學習RGB,學習方案如下:

Option Explicit
Dim Brr
Priv ...
Andy2483 發表於 2024-2-2 13:37

報告大大
是偵錯
謝謝大大

作者: Andy2483 時間: 2024-2-2 14:17

回復 20# coafort

新增程式碼到原有程式碼裡需要整理一下,請把整個工作表模組裡的程式碼貼上來

作者: coafort 時間: 2024-2-2 15:30

回復 coafort

新增程式碼到原有程式碼裡需要整理一下,請把整個工作表模組裡的程式碼貼上來
Andy2483 發表於 2024-2-2 14:17

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
'↑以下是關於儲存格編輯觸發的程序
   If .Count > 1 Or .Item(1) = "" Then Exit Sub
   '↑如果觸發格數量大於 1 或觸發格的下方格是空白!就結束程式執行
   If Not Intersect([AR212:AR219,AX212:AX219,AD222,AF222], .Cells) Is Nothing Then
   '↑如果觸發格是在[A2:A2]儲存格裡??
      .Cells(1, 2) = Val(.Cells(1, 2)) + Val(.Value)
   '↑令觸發格的右邊那1格的值 + (觸發格值以Val 函數轉化回傳的數值)

      '觸發格本身是.Cells(1,1), 右側1格是.Cells(1,2), 左側1格是.Cells(1,0),
      '上方1格是.Cells(0,1), 下方1格是.Cells(2,1)

      .ClearContents
      '↑清除觸發格的內容
      '此清除的程序再次的觸發了,但是 .Item(1) = "" 所以結束程式執行
   End If
End With
End Sub

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim a As Range, b As Range, c As Range
With Target
Set b = [AG212:AG219,AF212:AF219]
Set c = [AR212:AR219,AX212:AZ219]
For Each a In b
   If a.Interior.ColorIndex = 6 Then a.Interior.ColorIndex = xlNone
Next
Set c = Intersect(.Cells, c)
If Not c Is Nothing Then Intersect(c.EntireRow, b).Interior.ColorIndex = 6
End With
End Sub

謝謝大大
:D

作者: Andy2483 時間: 2024-2-2 15:52

回復 22# coafort

Option Explicit '←這是偵測所使用的變數有沒有做宣告,要放最上面
Dim Brr '←這是同模組共用變數要放第2行
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
   If .Count > 1 Or .Item(1) = "" Then Exit Sub
   If Not Intersect([AR212:AR219,AX212:AX219,AD222,AF222], .Cells) Is Nothing Then
      .Cells(1, 2) = Val(.Cells(1, 2)) + Val(.Value)
      .ClearContents
   End If
End With
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim b As Range, c As Range, i&
With Target
Set b = [AJ212:AJ219]: Set c = [AR212:AR219,AX212:AZ219]
If Not IsArray(Brr) Then
   ReDim Brr(1 To b.Count, 1 To 3)
   For i = 1 To UBound(Brr)
      Brr(i, 1) = b(i).Interior.Color Mod 256
      Brr(i, 2) = b(i).Interior.Color \ 256 Mod 256
      Brr(i, 3) = b(i).Interior.Color \ 256 ^ 2 Mod 256
   Next
End If
Set c = Intersect(.Cells, c)
If Not c Is Nothing Then
   Intersect(c.EntireRow, b).Interior.Color = RGB(255, 255, 0) '黃色
   Else
   For i = 1 To UBound(Brr)
      If b(i).Interior.Color = RGB(255, 255, 0) Then b(i).Interior.Color = RGB(Brr(i, 1), Brr(i, 2), Brr(i, 3))
   Next
   Brr = Empty
End If
End With
End Sub

作者: coafort 時間: 2024-2-2 16:00

回復 coafort

Option Explicit '←這是偵測所使用的變數有沒有做宣告,要放最上面
Dim Brr '←這是同模 ...
Andy2483 發表於 2024-2-2 15:52

報告大大，離開後黃色底不會消失
謝謝大大

作者: Andy2483 時間: 2024-2-2 16:05

回復 24# coafort

離開[AR212:AR219,AX212:AZ219] 這些範圍才會恢復原底色

作者: coafort 時間: 2024-2-2 16:11

回復 coafort

離開[AR212:AR219,AX212:AZ219] 這些範圍才會恢復原底色
Andy2483 發表於 2024-2-2 16:05

底色跑去AJ那邊去了
謝謝大大

作者: Andy2483 時間: 2024-2-2 16:45

回復 26# coafort

請問大大
如果我要精確一點
焦點在AR212至AR219及AX212至AZ219
變色的地方是AJ212至AJ219
請問該怎麼做呢？謝謝大大

原來就是AJ欄變色,有會錯意嗎?

作者: coafort 時間: 2024-2-3 04:52

回復 27# Andy2483

我說錯了
應該是說
黃底會累計不會消失
除非離開游標儲存格
謝謝大大

作者: 准提部林 時間: 2024-2-3 10:35

利用格式條件變色//保留原有格式

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xA As Range, xB As Range, X As Range, R&
Set xA = [AR212:AR219,AX212:AZ219]
Set xB = [AJ212:AJ219]
With Target
   If xB.FormatConditions.Count Then xB.FormatConditions.Delete
   If .Count > 1 Then Exit Sub
   Set X = Intersect(.Cells, xA)
   If X Is Nothing Then Exit Sub
   R = X.Row - xA.Item(1).Row + 1
   With xB.Item(R).FormatConditions
      .Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""^_^"""
      .Item(1).Interior.ColorIndex = 6
   End With
End With
End Sub

作者: 准提部林 時間: 2024-2-3 10:40

回復 1# coafort

發問時, 請上傳檔案並模擬結果, 若無法上傳檔案, 也可貼圖上來!!!
問題描述一定要完整且到位, 不要讓解答者一改再改, 花費太多時間~~

作者: coafort 時間: 2024-2-4 14:06

利用格式條件變色//保留原有格式

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ...
准提部林發表於 2024-2-3 10:35

非常謝謝准提大大
非常謝謝安迪大大
下次改進:'(

作者: coafort 時間: 2024-2-4 14:10

利用格式條件變色//保留原有格式

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ...
准提部林發表於 2024-2-3 10:35

其實是小的把欄位搞錯了
真的是非常抱歉
實際上應該是
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xA As Range, xB As Range, X As Range, R&
Set xA = [AR212:AR219,AX212:AX219]
Set xB = [AG212:AG219]
With Target
   If xB.FormatConditions.Count Then xB.FormatConditions.Delete
   If .Count > 1 Then Exit Sub
   Set X = Intersect(.Cells, xA)
   If X Is Nothing Then Exit Sub
   R = X.Row - xA.Item(1).Row + 1
   With xB.Item(R).FormatConditions
      .Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""^_^"""
      .Item(1).Interior.ColorIndex = 6
   End With
End With
End Sub

請問大大
如果AF212:AF219也要一起變色
該如何加入呢？
我改成以下這樣只有AF有作用但是AG沒作用
謝謝大大

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xA As Range, xB As Range, X As Range, R&
Set xA = [AR212:AR219,AX212:AX219]
Set xB = [AF212:AF219,AG212:AG219]
With Target
   If xB.FormatConditions.Count Then xB.FormatConditions.Delete
   If .Count > 1 Then Exit Sub
   Set X = Intersect(.Cells, xA)
   If X Is Nothing Then Exit Sub
   R = X.Row - xA.Item(1).Row + 1
   With xB.Item(R).FormatConditions
      .Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""^_^"""
      .Item(1).Interior.ColorIndex = 6
   End With
End With
End Sub

作者: 准提部林 時間: 2024-2-4 15:01

回復 32# coafort

Set xB = [AF212:AG219]

With xB.Rows(R).FormatConditions

作者: coafort 時間: 2024-2-4 19:40

回復 coafort

Set xB = [AF212:AG219]

With xB.Rows(R).FormatConditions
准提部林發表於 2024-2-4 15:01

非常謝謝准大大
可以了:D

作者: hcm19522 時間: 2024-4-11 15:04

(搜尋輸入編號12626) google網址:https://hcm19522.blogspot.com/

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)