12
返回列表 上一主題 發帖

如何利用VBA觸發儲存格產生日期.時間

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
5# 跳轉到 »
發表於 2016-1-8 15:42 | 只看該作者
本帖最後由 yen956 於 2016-1-8 15:55 編輯

試試看!!
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2.     Dim Lst As Integer, r As Integer
  3.     Lst = [A65536].End(xlUp).Row
  4.     If Target.Count > 2 Then Exit Sub  '如果一次改變多格則沒作用
  5.     r = Target.Row
  6.     If r > Lst Then Exit Sub  '如果最下面的部門為空白則沒作用
  7.    
  8.     '如果改變的儲存格不在 B欄 或 C欄 則沒作用
  9.     If Target.Column <> 2 And Target.Column <> 3 Then Exit Sub
  10.    
  11.     '如果 Target 為空白, 則隔兩欄反白, 並清除[Fxx]
  12.     If Target = "" Then
  13.         Target.Offset(0, 2) = ""
  14.         Target.Offset(0, 2).Interior.ColorIndex = 35
  15.         Cells(r, 6) = ""
  16.     Else
  17.         Target.Offset(0, 2) = Now    '否則隔兩欄取消反白, 填入現在時間
  18.         Target.Offset(0, 2).Interior.ColorIndex = xlNone
  19.     End If
  20.         
  21.     '如果 [Dxx] 及 [Exx] 不是空白, 在 [Fxx] 計算時差(以分鐘為單位)
  22.     If Cells(r, 4) <> "" And Cells(r, 5) <> "" Then
  23.         Cells(r, 6) = Int((Cells(r, 5) - Cells(r, 4)) * 24 * 60)
  24.     End If
  25. End Sub
複製代碼
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
4#
發表於 2016-1-8 15:39 | 只看該作者
回復 2# ML089
感謝 ML089超版的VBA的

TOP

man65boy

帖子
169 
主題
39 
精華
0 
積分
252 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
註冊時間
2011-4-17 
最後登錄
2020-7-17 

2012龍年全勤獎章2011兔年全勤獎章
3#
發表於 2016-1-8 15:29 | 只看該作者
回復 2# ML089

真多謝ML089老師的回答，如果輸入日期.時間後，我在手動更改起始時間或結束時間，可否讓統計的"分"，也同時同步變更加總，麻煩老師了^^

TOP

ML089

帖子
2025 
主題
13 
精華
0 
積分
2053 
點名
0  
作業系統
WIN7 
軟體版本
Office2007 
閱讀權限
100 
性別
男 
來自
台北市 
註冊時間
2011-3-2 
最後登錄
2024-3-14 

論壇榮譽勳章論壇贊助勳章熱烈參與勳章2014馬年全勤獎章2015羊年全勤獎章2016猴年全勤獎章
2#
發表於 2016-1-8 14:54 | 只看該作者
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. Dim r%, xD As Range, xE As Range, xF As Range
  3. With Target
  4.       If .Count > 1 Then Exit Sub
  5.       If Intersect(Union([B:B], [C:C]), .Cells) Is Nothing Then Exit Sub
  6.       Application.EnableEvents = False
  7.       .Offset(0, 2).Value = Now()
  8.       r = .Row() - 1: Set xD = [D1].Offset(r, 0): Set xE = [E1].Offset(r, 0): Set xF = [F1].Offset(r, 0)
  9.       If Application.Count(xD, xE) = 2 Then xF = Int((xE - xD) * 24 * 60)
  10.       Application.EnableEvents = True
  11. End With
  12. End Sub
複製代碼
{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
12
返回列表 上一主題