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

Private Sub Worksheet_Change(ByVal Target As Range) '儲存格改變時才會觸發 target 就是你原先變更資料的儲存格(不是新選到的)
If Target.Count > 1 Then Exit Sub '選到兩格以上強制結束(跑下去會出問題,本sub內的提到的"選到的格子"皆為尚未點擊之前選到的格子)
If Target.Column <> 5 Then Exit Sub '選到不是第五欄強制結束(跑下去會出問題)
If Target.Row = 1 Then Exit Sub '選到第一列強制結束(跑下去會出問題)
If Target.Value = "" Then Exit Sub '選到格子內無任何資料強制結束(跑下去會出問題)
Target.Font.ColorIndex = xlAutomatic '顏色變回黑
Set s = ActiveSheet '將工作表縮寫後面使用縮寫方便
On Error Resume Next '允許發生錯誤不再跳出提示錯誤警告視窗
f = 0
f = s.Columns("A:M").Find("*", searchdirection:=2).Row '查找最後一列 , "*" 找尋A~M欄非空白有資料的格子 searchdirection:=2由下往上查找
If f = 0 Then Exit Sub '如果f還是0 代表沒資料不跑
On Error GoTo 0 '不允許發生錯誤回復成提示錯誤警告視窗
k = s.Cells(Target.Row, "K") '查找該同一列的 k欄值
x = 0 '紀錄加總用的x
For i = 2 To f '迴圈 (從第二列找到最後一列)
If Str(k) = Str(s.Cells(i, "K")) Then x = x + s.Cells(i, "H") '找到相同的產品編號將H欄值持續加總到x
Next
'到這邊已經加總完全同一個編號的數量
Application.EnableEvents = False '關閉事件觸發以免連續影響其他的觸發事件 selection 與 change
For i = 2 To f
If Str(k) = Str(s.Cells(i, "K")) Then s.Cells(i, "M") = x '找到相同的產品編號並且將加總好的x放到同一列的M欄
Next
Application.EnableEvents = True '重新開啟事件觸發
Set s = Nothing
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '儲存格點選時才會觸發 target 就是你當下點的儲存格(新選到的)
If Target.Count > 1 Then Exit Sub '選到兩格以上強制結束(跑下去會出問題)
If Target.Row = 1 Then Exit Sub '選到第一列強制結束(跑下去會出問題)
If Target.Value = "" Then Exit Sub '選到格子內無任何資料強制結束(跑下去會出問題)
If Target.Column <> 16 Then Exit Sub '選到不是第P欄強制結束(跑下去會出問題)
Set s = ActiveSheet '將工作表縮寫後面使用縮寫方便
On Error Resume Next '允許發生錯誤不再跳出提示錯誤警告視窗
f = 0
f = s.Columns("K").Find(Target.Value, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=1).Row 'searchdirection:=1由上往下查找只找K欄找到相同的編號
If f = 0 Then Exit Sub '找不到符合項目強制結束(跑下去會出問題)
On Error GoTo 0
Application.EnableEvents = False '關閉事件觸發
s.Cells(f, "E").Select '點選找到的儲存格
s.Cells(f, "E").Font.Color = -16776961 '並將顏色改為紅
SendKeys "{F2}" '並進入修改模式 f2本身為excel的功能
Application.EnableEvents = True '重新開啟事件觸發
Set s = Nothing
End Sub

複製代碼