Andy2483

回復 20# coafort

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

coafort

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

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

回復  coafort

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

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

Andy2483

回復 24# coafort

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

coafort

回復  coafort

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

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

Andy2483

回復 26# coafort

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

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

coafort

回復 27# Andy2483

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

准提部林

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

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

准提部林

回復 1# coafort


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