Andy2483

回復 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

Andy2483

回復 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

Andy2483

回復 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

Andy2483

回復 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

Andy2483

回復 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

Andy2483

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

下載 (32.42 KB)

2024-2-2 11:19

選取後變黃色:

下載 (32.86 KB)

2024-2-2 11:20

移開後恢復原色:

下載 (32.42 KB)

2024-2-2 11:22

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

Andy2483

回復 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

Andy2483

回復 20# coafort

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

Andy2483

回復 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

Andy2483

回復 24# coafort

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