Excel VBA 日付・時刻・時間

Private Sub 待ち�@()    'Excelの画面が表示されていると、CPUの負荷が高い
Dim newHour, newMinute, newSecond, waitTime
    newHour = Hour(Now())
    newMinute = Minute(Now())
    newSecond = Second(Now()) + 2
    waitTime = TimeSerial(newHour, newMinute, newSecond)
    Application.Wait waitTime
End Sub


Private Sub 待ち�A()
    Application.Wait Time:=Now + TimeValue("00:00:02")  '2秒間停止します。
End Sub


'待ち�B
Sub テスト()
   Call 指定秒待つ(0.5)                      ' 中断時間は引数で指定します。
   MsgBox "終了"
End Sub

Private Sub 指定秒待つ(待ち時間 As Single) ' 中断時間は引数で指定します。
   Dim 再開時刻 As Single
   
   再開時刻 = Timer + 待ち時間
   Do While Timer < 再開時刻
      DoEvents                               ' 他のプロセスに制御を渡します。
   Loop
End Sub


'待ち�C
Sub テスト2()
   Call 指定秒待つ2(5)                               ' 中断時間は引数で指定します。
   MsgBox "終了"
End Sub

Private Sub 指定秒待つ2(待ち時間 As Integer)       ' 中断時間は引数で指定します。
   Dim 起点時刻 As Variant
   
   起点時刻 = Now
   Do While DateDiff("s", 起点時刻, Now) < 待ち時間
      DoEvents                                      ' 他のプロセスに制御を渡します。
   Loop
End Sub

'待ち�D
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'これで Sleepを使ってミリ秒単位で処理にウェイトを入れることができます。
Private Sub 指定秒待つ3(待ち時間 As Integer)   
   DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
   Sleep (待ち時間 * 1000)
End Sub

Dim MyTime
MyTime = TimeValue("4:35:17 PM")            ' 時刻を返します。

Private Sub フォルダを次々調べてデータを取得(フォルダ)

   For Each サブフォルダ In フォルダ.SubFolders

      If InStr(サブフォルダ.Name, "対象外") = 0 Then

         処理フォルダ = サブフォルダ.Path

         Set フォルダ_オブジェクト = ファイルシステムオブジェクト.getfolder(処理フォルダ)

         For Each ファイル In フォルダ_オブジェクト.Files
            ファイル名 = ファイル.Name
            ファイルフルパス = ファイル.Path
            拡張子 = ファイルシステムオブジェクト.GetExtensionName(ファイル名)

            If LCase(拡張子) = "xls" Or LCase(拡張子) = "xlsx" Then

               If 検査レポートブック索引.Exists(ファイル名) = False Then
                  '★集計済みブック索引に存在しない場合

                  '開いたファイル名を、テキスト出力する
                  出力テキストストリームオブジェクト.WriteLine ファイルフルパス         ' 改行(CrLf)付き

                  Call 検査レポートのデータを取得

               End If  '対象は、未集計ブックのみ

            End If  '対象は、エクセルブックのみ

            If Now >= ファイル保存時刻 + TimeValue("0:05:00") Then
               '検査レポートに不適切なファイルが有って中断しても再開が容易なように、5分おきに強制保存
               ファイル保存時刻 = Now

               Application.DisplayAlerts = False
               集計ブック.SaveAs Filename:= _
               ThisWorkbook.Path & "\" & Left(集計ブック名, InStrRev(集計ブック名, ".") - 1) _
               & "_" & Format(ファイル保存時刻, "yyyymmdd_hhmm") & ".xlsx"
               Application.DisplayAlerts = True
            End If

         Next '★サブフォルダーに登録された、すべてのファイル

         Call フォルダを次々調べてデータを取得(サブフォルダ) '再帰呼び出しで、下位のフォルダ全てを対象とする
      End If
   Next '★フォルダに登録された、「対象外」を含まないすべてのサブフォルダー

End Sub

Option Explicit
Dim 開始秒 As Single
Dim 開始日時 As Variant

Private Sub 開始時刻取得�@()
   開始秒 = Timer                ' 開始時刻を変数に格納します。
End Sub

Private Sub 経過時間計測�@()
Dim 終了秒 As Single
Dim 処理秒 As Long

Dim 経過時間 As Integer
Dim 経過分数 As Integer
Dim 経過秒数 As Integer

   終了秒 = Timer                ' 終了時刻を変数に格納します。
   処理秒 = 終了秒 - 開始秒    ' 処理時間(秒)を計算します。
   経過時間 = 処理秒 \ 3600
   経過分数 = (処理秒 Mod 3600) \ 60
   経過秒数 = (処理秒 Mod 3600) Mod 60
   MsgBox "処理(所要)時間は、" & 経過時間 & " 時間 " _
   & 経過分数 & " 分 " & 経過秒数 & " 秒でした。"
End Sub



Private Sub 開始時刻取得�A()
   開始日時 = Now                ' 開始時刻を変数に格納します。
End Sub

Private Sub 経過時間計測�A()
Dim 終了日時 As Variant
Dim 所要時間 As Variant

   終了日時 = Now                '終了時刻を取り出す
   所要時間 = Abs(DateDiff("s", 開始日時, 終了日時))
   MsgBox "所要時間は、" & 所要時間 & " 秒でした。"
End Sub



Private Sub 経過時間計測�B() '★推奨★
Dim 開始日時 As Variant
Dim 終了日時 As Variant
   開始日時 = Now                ' 開始時刻を変数に格納します。
   '処理
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub

Option Explicit
Sub 計算()
Dim i As Integer
Dim j As Integer
   i = 1000
   j = 2000
   Range("A1") = i * j
End Sub

? now
2011/10/01 11:13:53 

? Format(Now, "yyyymmdd_hhnn")
20111001_1118

Option Explicit

Dim 今年 As String
Dim 元日 As Date
Dim 今年の年間通算日 As Integer

'★★★★★★

Sub 日数�@()
   今年 = DatePart("yyyy", Date)
   元日 = DateValue(今年 & "/1/1")
   今年の年間通算日 = DateDiff("d", 元日, Date) + 1
   MsgBox "今日は今年になって " & 今年の年間通算日 & " 日目です"
End Sub

'★★★★★★

Sub 日数�A()
   今年の年間通算日 = DatePart("y", Date)
   MsgBox "今日は今年になって " & 今年の年間通算日 & " 日目です"
End Sub

Option Explicit
Option Base 1

Function さかのぼり稼働日(起点日 As Date, さかのぼり稼働日数 As Integer) As Date
'Sub 稼働日()
   Dim カレンダーシート As Worksheet
   Dim カレンダ配列() As Variant
   Dim 最終行 As Integer
   Dim 処理列 As Integer
   Dim 処理行 As Integer
   Dim 起点日行 As Integer
   Dim 起点日列 As Integer
   Dim 年 As Integer
   Dim さかのぼり日列 As Integer
   Dim さかのぼり日行 As Integer
   
'   Dim 起点日 As Date
'   Dim さかのぼり稼働日数 As Integer
'   Dim さかのぼり稼働日 As Date
'
'   起点日 = "2014/4/15"
'   さかのぼり稼働日数 = 3
'Stop

   Set カレンダーシート = ThisWorkbook.Worksheets("工場カレンダー")
   最終行 = カレンダーシート.Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
   カレンダ配列 = カレンダーシート.Range("A4").Resize(最終行 - 3, 33)
   
   '起点日の配列上の位置を知る
   年 = Format(起点日, "YYYY")
   
   起点日行 = Format(起点日, "MM") * 3
   
   If 年 = 2015 Then
      起点日行 = 起点日行 + 36
   End If
   
   起点日列 = Format(起点日, "DD") + 2
   
   '起点日が休日なら、さかのぼる
   Do While カレンダ配列(起点日行, 起点日列) <> ""
      If 起点日列 > 2 Then '同一月内
            起点日列 = 起点日列 - 1
      Else '月またがり
         起点日行 = 起点日行 - 3
         起点日列 = 34
      End If
   Loop
   
   さかのぼり日行 = 起点日行
   さかのぼり日列 = 起点日列
   
   Do While さかのぼり稼働日数 > 0
      If さかのぼり日行 <= 3 And さかのぼり日列 < 3 Then
         MsgBox "カレンダー範囲の外になります！"
         さかのぼり稼働日 = "#VALUE!"
         Exit Function
      End If
      If さかのぼり日列 > 2 Then '同一月内
         If カレンダ配列(さかのぼり日行, さかのぼり日列 - 1) = "" Then
            さかのぼり日列 = さかのぼり日列 - 1
            さかのぼり稼働日数 = さかのぼり稼働日数 - 1
         Else
            さかのぼり日列 = さかのぼり日列 - 1
         End If
      Else '月またがり
         さかのぼり日行 = さかのぼり日行 - 3
         さかのぼり日列 = 34
      End If
   Loop
   
   If さかのぼり日行 > 36 Then
      さかのぼり日行 = さかのぼり日行 - 36
      年 = 2015
   Else
      年 = 2014
   End If
   
   さかのぼり稼働日 = CDate(CStr(年) & "/" & CStr(さかのぼり日行 / 3) & "/" & CStr(さかのぼり日列 - 2))

'End Sub
End Function

Sub 月()

   Dim 今月 As Date
   Dim 間隔 As Integer
   Dim 文字列 As String
   
   今月 = "2011/12/05" '日付として認識される書式の文字列
   文字列 = "過去　　月間隔" & vbNewLine
   For 間隔 = -11 To 0
      文字列 = 文字列 & DateAdd("m", 間隔, 今月) & " " & 間隔 & vbNewLine
   Next 間隔
   文字列 = 文字列 & String(4, vbNewLine)
   MsgBox 文字列
   
   文字列 = "未来　　月間隔" & vbNewLine
   For 間隔 = 0 To 11
      文字列 = 文字列 & DateAdd("m", 間隔, 今月) & " " & 間隔 & vbNewLine
   Next 間隔
   文字列 = 文字列 & String(4, vbNewLine)
   MsgBox 文字列
   
   文字列 = "未来　　月間隔" & vbNewLine
   For 間隔 = 0 To 11
      文字列 = 文字列 & Format(DateAdd("m", 間隔, 今月), "yyyymm") & " " & 間隔 & vbNewLine
   Next 間隔
   文字列 = 文字列 & String(4, vbNewLine)
   MsgBox 文字列
   
End Sub

Sub 文字列型変数と日付型変数()

   Dim 英字 As String
   Dim 数字 As String
   Dim 数字スラッシュ付 As String

   英字 = "JAN.2014"
   数字 = "20140101"

   'CDateの引数は、日付書式のみ。IsDate でチェックする
   MsgBox 英字 & "は、" & IsDate(英字) & vbNewLine _
         & 数字 & "は、" & IsDate(数字)

   数字スラッシュ付 = Left(数字, 4) & "/" & Mid(数字, 5, 2) & "/" & Right(数字, 2)

   MsgBox 英字 & " は、ピリオドを外して " _
      & "CDate すると " & CDate(Replace(英字, ".", " ")) & vbNewLine _
      & 数字 & " は、スラッシュを挿入して " _
      & "CDate すると " & CDate(数字スラッシュ付) & vbNewLine _
      & "になります。"

   MsgBox 数字 & " の 1日前は、スラッシュを挿入して " _
      & "CDate して、DateAdd で一日引いて、Format で文字列に戻すと" & vbNewLine _
      & Format(DateAdd("d", -1, CDate(数字スラッシュ付)), "yyyymmdd") & vbNewLine _
      & "に、できます。"

End Sub

Sub テスト()
   Dim 年月 As String

   年月 = "201201"
   If Val(Right(年月, 2)) = 1 Then
      年月 = CStr(Val(Left(年月, 4) - 1)) & "12"
   Else
      年月 = Left(年月, 4) & Right("0" & CStr(Val(Right(年月, 2)) - 1), 2)
   End If
   MsgBox 年月
End Sub