GBKEE

回復 1# yeh6712

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim i As Integer, M As Variant, S As Integer, Rng As Range
   
4.     i = 2
   
5.     With Sheets("成績總表")
   
6.         Do While .Cells(i, "C") <> ""
   
7.             S = 0               '不是男女
   
8.             If .Cells(i, "C") = "男" Then
   
9.                 S = 1                'A欄
   
10.             ElseIf .Cells(i, "C") = "女" Then
    
11.                 S = 4                'D欄
    
12.             End If
    
13.             If S > 0 And .Cells(i, "D") > 0 Then   '條件: 有欄位 且 仰臥起坐次數 > 0
    
14.                 If .Cells(i, "D") < Sheets("仰臥起坐").Columns(S).Cells(2, 1) Then
    
15.                     M = Application.Match(.Cells(i, "D"), Sheets("仰臥起坐").Columns(S), 0)
    
16.                 ElseIf .Cells(i, "D") >= Sheets("仰臥起坐").Columns(S).Cells(2, 1) Then
    
17.                     M = 2  '100分
    
18.                 End If
    
19.                 If IsNumeric(M) Then .Cells(i, "E") = Sheets("仰臥起坐").Columns(S).Cells(M, 2)
    
20.                 'Application.Match 工作表的函數:沒有找到時傳回 錯誤值               
    
21.             End If
    
22.             i = i + 1
    
23.         Loop
    
24.     End With
    
25. End Sub

複製代碼

GBKEE

回復 5# yeh6712

1. Option Explicit
   
2. '成績總表 工作表模組: 工作表上儲存格有修改的預設程式
   
3. Private Sub Worksheet_Change(ByVal Target As Range)  'Target變數->工作表上有改變值的儲存格
   
4.     Dim Rng As Range, S As Integer, T As Range
   
5.     If Target.Column = 3 Or Target.Column = 4 Then 'C欄 或 D欄
   
6.         Set T = Cells(Target.Row, "D")              'D欄
   
7.         If (Cells(Target.Row, "C") = "男" Or Cells(Target.Row, "C") = "女") And IsNumeric(T) Then
   
8.             With Sheets("仰臥起坐")
   
9.                 If Cells(Target.Row, "C") = "男" Then
   
10.                     Set Rng = .Range("A2:A" & .[A2].End(xlDown).Row)
    
11.                 Else
    
12.                     Set Rng = .Range("D2:D" & .[D2].End(xlDown).Row)
    
13.                 End If
    
14.             End With
    
15.             If T >= Rng.Cells(1) Then
    
16.                 T.Cells(1, 2) = Rng.Cells(1, 2)
    
17.             ElseIf T < Rng.Cells(1) And T > 0 Then
    
18.                 S = Rng.Cells(1) - T
    
19.                 T.Cells(1, 2) = Rng.Cells(S + 1, 2)
    
20.             Else
    
21.                 T.Cells(1, 2) = ""    'E欄
    
22.             End If
    
23.         Else
    
24.            If T.Row > 1 Then T.Cells(1, 2) = ""      ' E欄 列數>1
    
25.         End If
    
26.     End If
    
27. End Sub

複製代碼

GBKEE

回復 9# yeh6712
   

例： 預設C1=A1+B1  ，A1輸入2 ， B1輸入3 ，則C1自動算出5
這時，儲存格C1就不算是有修改過嗎

公式值的改變用重算事件

1. Private Sub Worksheet_Calculate()
   
2. MsgBox "A"
   
3. End Sub

複製代碼

還有許多 工作表的觸動事件程序可用

下載 (55.37 KB)

2014-4-10 06:16

GBKEE

回復 11# yeh6712
詳看 10# 的圖示
重算事件 ,Change 事件 需二擇一執行,

1. Option Explicit
   
2. Private Sub Worksheet_Calculate()
   
3.     Dim i As Integer, M As Variant, S As Integer, Rng As Range
   
4.     i = 2
   
5.     Do While Cells(i, "F").Formula <> ""  '有公式
   
6.             S = 0               '不是男女
   
7.             If Cells(i, "C") = "男" Then
   
8.                 S = 1                'A欄
   
9.             ElseIf Cells(i, "C") = "女" Then
   
10.                 S = 4                'D欄
    
11.             End If
    
12.             If S > 0 And Cells(i, "F") > 0 Then
    
13.                 If Cells(i, "F") < Sheets("仰臥起坐").Columns(S).Cells(2, 1) Then
    
14.                     M = Application.Match(Cells(i, "F"), Sheets("仰臥起坐").Columns(S), 0)
    
15.                 ElseIf Cells(i, "F") >= Sheets("仰臥起坐").Columns(S).Cells(2, 1) Then
    
16.                     M = 2  '100分
    
17.                 End If
    
18.                 If IsNumeric(M) Then Cells(i, "G") = Sheets("仰臥起坐").Columns(S).Cells(M, 2)
    
19.                 'Application.Match 工作表的函數:沒有找到時傳回 錯誤值
    
20.             Else
    
21.                 Cells(i, "G") = ""
    
22.             End If
    
23.             i = i + 1
    
24.     Loop
    
25. End Sub

複製代碼