代碼修正 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 代碼修正

返回列表下一主題上一主題發帖

[發問] 代碼修正

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

1^# 跳轉到 »

發表於 2024-1-15 09:06 | 顯示全部帖子

本帖最後由 Andy2483 於 2024-1-15 10:11 編輯

回復 1# wayne0303

謝謝前輩發表此主題
程序執行可以用,可以正確執行最重要,如果能明確指出問題癥結或上傳範例,比較容易理解需求
前輩提供範例理解如下:
Option Explicit
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"))
'↑令xA變數是觸發格與U欄的交集儲存格
If xA Is Nothing Then GoTo xA0
'↑如果xA變數沒交集到任何儲存格!就跳到標示xA0位置繼續執行
For Each xR In xA
'↑設逐項迴圈!令xR變數是xA這交集格的一格
Range(Cells(xR.Row, 1), Cells(xR.Row, 22)).Font.ColorIndex = 15 ^ -(xR > 1)
'↑令儲存格文字顏色是灰色或黑色
'儲存格:xR當列A欄到V欄之間的連續儲存格
Next

xA0:
Set xA = Intersect(Target, Range("O:O"))
'↑令xA變數是觸發格與O欄的交集儲存格
If xA Is Nothing Then GoTo xA1
'↑如果xA變數沒交集到任何儲存格!就跳到標示xA1位置繼續執行
For Each xR In xA
'↑設逐項迴圈!令xR變數是xA這交集格的一格
Range(Cells(xR.Row, 16), xR).Font.ColorIndex = 2 ^ -(xR = "")
'↑令儲存格文字顏色是白色或黑色
'儲存格:xR當列O欄到P欄之間的連續儲存格
Next

xA1:
Set xA = Intersect(Target, Range("J:J"))
'↑令xA變數是觸發格與J欄的交集儲存格
If xA Is Nothing Then GoTo xA2
'↑如果xA變數沒交集到任何儲存格!就跳到標示xA2位置繼續執行
For Each xR In xA
'↑設逐項迴圈!令xR變數是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")
'↑令儲存格文字顏色是淺藍色或黑色,令儲存格文字是粗體或非粗體
'儲存格:xR當列J欄儲存格
Next

xA2:
Set xA = Intersect(Target, Range("v:v"))
'↑令xA變數是觸發格與V欄的交集儲存格
If xA Is Nothing Then GoTo xA3
'↑如果xA變數沒交集到任何儲存格!就跳到標示xA3位置繼續執行
For Each xR In xA
'↑設逐項迴圈!令xR變數是xA這交集格的一格
Range(Cells(xR.Row, 1), xR).Font.Color = RGB(153, 102, 0) ^ -((xR Like "*拆圖"))
'↑令儲存格文字顏色是土色或黑色
'儲存格:xR當列A欄到V欄之間的連續儲存格
Next

xA3:
Set xA = Intersect(Target, Range("p:p"))
'↑令xA變數是觸發格與P欄的交集儲存格
If xA Is Nothing Then GoTo xA4
'↑如果xA變數沒交集到任何儲存格!就跳到標示xA4位置繼續執行
For Each xR In xA
'↑設逐項迴圈!令xR變數是xA這交集格的一格
Range(Cells(xR.Row, 1), Cells(xR.Row, 22)).Font.ColorIndex = 5 ^ -(xR.Font.Strikethrough = True)
'↑令儲存格文字顏色是藍色或黑色
'儲存格:xR當列A欄到V欄之間的連續儲存格
Next

xA4:
Set xA = Intersect(Target, Range("E:E"))
'↑令xA變數是觸發格與E欄的交集儲存格
If xA Is Nothing Then Exit Sub
'↑如果xA變數沒交集到任何儲存格!就結束程式執行
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)
'↑設逐項迴圈!令cell變數是本表E欄裡的儲存格
st = IIf(cell.Value = "", "", _
IIf(cell.Offset(0, -1).Value > 0, "LOB", _
IIf(Application.WorksheetFunction.CountIf(cell, "S1A*") > 0, "TM", "MU")))
'↑令st變數是IIf()回傳值
cell.Offset(0, -3).Value = st
'↑令cell變數左3格儲存格值是st變數
Next
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

2^#

發表於 2024-1-15 10:12 | 顯示全部帖子

謝謝論壇,謝謝各位前輩
後學練習方案如下,請各位前輩指教
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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

3^#

發表於 2024-1-15 10:21 | 顯示全部帖子

回復 4# wayne0303

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

4^#

發表於 2024-1-16 08:06 | 顯示全部帖子

回復 6# wayne0303

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

5^#

發表於 2024-1-16 09:43 | 顯示全部帖子

回復 8# wayne0303

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

6^#

發表於 2024-1-17 10:22 | 顯示全部帖子

回復 10# wayne0303

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

以下是測試觸發次數的代碼
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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

靜思自在 : 世上有兩件事不能等：一、孝順二、行善。

返回列表下一主題上一主題