[發問] 代碼修正

wayne0303

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xA As Range, xR As Range
Application.ScreenUpdating = False
Set xA = Intersect(Target, Range("U:U"))
If xA Is Nothing Then GoTo xA0
For Each xR In xA
    Range(Cells(xR.Row, 1), Cells(xR.Row, 22)).Font.ColorIndex = 15 ^ -(xR > 1)
Next

xA0:
Set xA = Intersect(Target, Range("O:O"))
If xA Is Nothing Then GoTo xA1
For Each xR In xA
    Range(Cells(xR.Row, 16), xR).Font.ColorIndex = 2 ^ -(xR = "")
Next

xA1:
Set xA = Intersect(Target, Range("J:J"))
If xA Is Nothing Then GoTo xA2
For Each xR In xA
    Range(Cells(xR.Row, 10), xR).Font.Color = RGB(0, 176, 240) ^ -(xR = "L")
    Range(Cells(xR.Row, 10), xR).Font.Bold = (xR = "L")
Next

xA2:
Set xA = Intersect(Target, Range("v:v"))
If xA Is Nothing Then GoTo xA3
For Each xR In xA
    Range(Cells(xR.Row, 1), xR).Font.Color = RGB(153, 102, 0) ^ -((xR Like "*拆圖"))
Next


xA3:
Set xA = Intersect(Target, Range("p:p"))
If xA Is Nothing Then GoTo xA4
For Each xR In xA
    Range(Cells(xR.Row, 1), Cells(xR.Row, 22)).Font.ColorIndex = 5 ^ -(xR.Font.Strikethrough = True)
Next


xA4:
Set xA = Intersect(Target, Range("E:E"))
If xA Is Nothing Then Exit Sub

Dim st As String
Dim cell As Range

For Each cell In Me.Range("E2:E" & Me.Cells(Me.Rows.Count, "E").End(3).Row)
    st = IIf(cell.Value = "", "", _
                IIf(cell.Offset(0, -1).Value > 0, "LOB", _
                    IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
    cell.Offset(0, -3).Value = st
   
Next

End Sub

請大大們幫我修正一下藍色部分的代碼看怎麼寫比較順，謝謝

Andy2483

回復 10# wayne0303


可能是連續觸發,可以用以下方式試試看
Application.EnableEvents = False
'會產生連續觸發的位置,例如 cell.Offset(0, -3).Value = st
Application.EnableEvents = True
觸發次數:

下載 (29.91 KB)

2024-1-17 10:21

以下是測試觸發次數的代碼
Option Explicit
Dim N&
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, st$, cell As Range
With Target
   If .Column = 21 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.ColorIndex = 15 ^ -(Val(xR) > 1)
      Next
   End If
   If .Column = 15 Then
      For Each xR In .Cells
         Cells(xR.Row, 16).Font.ColorIndex = 2 ^ -(Trim(xR) = "")
      Next
   End If
   If .Column = 10 Then
      For Each xR In .Cells
         Cells(xR.Row, 10).Font.Color = RGB(0, 176, 240) ^ -(Trim(xR) = "L")
         Cells(xR.Row, 10).Font.Bold = (Trim(xR) = "L")
      Next
   End If
   If .Column = 22 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.Color = RGB(153, 102, 0) ^ -((xR Like "*拆圖"))
      Next
   End If
   If .Column = 16 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.ColorIndex = 5 ^ -(xR.Font.Strikethrough = True)
      Next
   End If
   N = N + 1
If .Column <> 5 Then Exit Sub
   For Each cell In Union(Range([e2], [e65536].End(3)), .Cells)
      st = IIf(Trim(cell) = "", "", IIf(Val(cell.Offset(0, -1)) > 1, "LOB", _
                    IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
      cell.Offset(0, -3).Value = st
      N = N + 1
      cell.Offset(0, 3).Resize(, 2) = IIf(cell <> "", 2, "")
      N = N + 1
   Next
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim MUCount&, TMCount&, cellValue, Arr, i&
Arr = Range([B2], [B65536].End(3)).Value
If IsArray(Arr) Then
   MUCount = 0: TMCount = 0
   For i = 1 To UBound(Arr, 1)
      cellValue = Arr(i, 1)
      If Not Cells(i + 1, "P").Font.Strikethrough Then
         If cellValue = "MU" Then
            MUCount = MUCount + 1
            ElseIf cellValue = "TM" Then
               TMCount = TMCount + 1
         End If
      End If
   Next
[A1] = "案件 " & MUCount & "／" & TMCount
N = N + 1
MsgBox "合計觸發: " & N & " 次"
End If
End Sub

wayne0303

回復 9# Andy2483


如附件，再麻煩Andy大查看一下
還有A1合併儲存格的案件統計也會有延遲的狀況

謝謝

Andy2483

回復 8# wayne0303


    我測試沒問題,再檢查一下或更明確說明/圖解/上傳範例

wayne0303

回復 7# Andy2483



感謝Andy大~
想再請問一下，我加了藍色部分的代碼，但將e欄清空的時候，h欄的數字卻跑到了h1?(正常是要跟著為空，但卻改了我h1本來的字)
謝謝！

If .Column <> 5 Then Exit Sub
   For Each cell In Union(Range("E2:E" & Cells(Rows.Count, "E").End(3).Row), .Cells)
      st = IIf(Trim(cell) = "", "", IIf(Val(cell.Offset(0, -1)) > 0, "LOB", _
                    IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
      cell.Offset(0, -3).Value = st
      cell.Offset(0, 3).Resize(, 2) = IIf(cell <> "", 2, "")
   Next

Andy2483

回復 6# wayne0303


For Each cell In Union(Me.Range("E2:E" & Me.Cells(Me.Rows.Count, "E").End(3).Row), .Cells)

wayne0303

回復 5# Andy2483


也是一樣...

還是是要改用您3# 的with寫呢？

Andy2483

回復 4# wayne0303


    可能是連續觸發,請試試3#的方案
      Application.EnableEvents = False
      cell.Offset(0, -3).Value = st
      Application.EnableEvents = True

wayne0303

回復 2# Andy2483

感謝andy大大回覆~

下面這段代碼在執行的時候會有延遲的狀況

• 像我都取消E欄的值了，B欄的結果還是沒有跟著取消....
  
• E3、D3有值，B3顯示結果，在E4輸入數據，B3才會給我跳正確的結果這樣...
  

    xA4:
Set xA = Intersect(Target, Range("E:E"))
If xA Is Nothing Then Exit Sub

Dim st As String
Dim cell As Range

For Each cell In Me.Range("E2:E" & Me.Cells(Me.Rows.Count, "E").End(3).Row)
    st = IIf(cell.Value = "", "", _
                IIf(cell.Offset(0, -1).Value > 0, "LOB", _
                    IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
    cell.Offset(0, -3).Value = st
   
Next

Andy2483

謝謝論壇,謝謝各位前輩
後學練習方案如下,請各位前輩指教
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xR As Range, st$, cell As Range
Application.ScreenUpdating = False
With Target
   If .Column = 21 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.ColorIndex = 15 ^ -(Val(xR) > 1)
      Next
   End If
   If .Column = 15 Then
      For Each xR In .Cells
         Cells(xR.Row, 16).Resize(, 2).Font.ColorIndex = 2 ^ -(Trim(xR) = "")
      Next
   End If
   If .Column = 10 Then
      For Each xR In .Cells
         Cells(xR.Row, 10).Font.Color = RGB(0, 176, 240) ^ -(Trim(xR) = "L")
         Cells(xR.Row, 10).Font.Bold = (Trim(xR) = "L")
      Next
   End If
   If .Column = 22 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.Color = RGB(153, 102, 0) ^ -((xR Like "*拆圖"))
      Next
   End If
   If .Column = 16 Then
      For Each xR In .Cells
         Cells(xR.Row, 1).Resize(, 22).Font.ColorIndex = 5 ^ -(xR.Font.Strikethrough = True)
      Next
   End If
   If .Column <> 5 Then Exit Sub
   For Each cell In Me.Range("E2:E" & Me.Cells(Me.Rows.Count, "E").End(3).Row)
      st = IIf(Trim(cell) = "", "", IIf(Val(cell.Offset(0, -1)) > 0, "LOB", _
                    IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
      Application.EnableEvents = False
      cell.Offset(0, -3).Value = st
      Application.EnableEvents = True
   Next
End With
End Sub