Set2-B01

Excel VBA Base Book
2023.09.19

Base Procedure Set 2（実行時間記入）

  1. 下記ボックス内をコピーし、標準モジュールに貼り付ける。
  2. モジュール名を【B01_Tool】に変更する。
　モジュール名：B01_Tool
Option Explicit　

'=================================================
'    64bit : Sleep使用のおまじない
'    Sleep 1000　　　　　　　　　　　　'1秒
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
'=================================================

' +++********************************************************+++
'    【Main】シート 作業開始時間記入 
'　　引数1:範囲　　　　　　　'例："B2"
' +++********************************************************+++
 Public Function InputStt(strRng As String) 
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets("Main") 
        .Select
        With Range(strRng)
            .Select
            .Interior.Color = RGB(255, 255, 102) '淡い黄色
            .Value = " 作業中" & Format(Time, "hh:mm: ss") & " ～" 
        End With
     End With
     Sleep 500
     Call exeBreak
End Function
' +++********************************************************+++
'     【Main】シート 作業終了時間記入
'　　引数1:範囲　　　　　　　'例："B2"
'　　引数2:実行時間
' +++********************************************************+++
Public Function InputEnd(strRng As String, exeTime As Date)
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets("Main")
        .Select
        With .Range(strRng)
            .Value = Format(Now, "yyyy/mm/dd hh:nn")
            .Interior.Color = xlNone '背景色無色
            .Select
            .Offset(0, 2) = Format(exeTime, "h:mm: ss")
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     【Main】シート エラー発生時間、作業時間 記入 
'　　引数1:範囲　　　　　　　'例："B2"
'　　引数2:実行時間
' +++********************************************************+++
Public Function InputErr(strRng As String)
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets("Main")
        .Select
        With Range(strRng)
            .Value = Format(Now, "yyyy/mm/dd hh: nn")
            .Interior.Color = rgbLightPink ' 背景色淡いピンク
            .Select
            .Offset(0, 2) = "エラー終了"
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     ■作業開始時間 記入
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
'　　引数3:実行メニュー名　　'例："省略中"
' +++********************************************************+++
Public Function InputSttSht(shtName As String, strRng As String, _
                            myProcd As String)
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With Range(strRng)
            .Select
            .Interior.Color = RGB(255, 255, 102) '淡い黄色
            .Value = myProcd & " 中" & Format(Time, "hh.mm: ss") & " ~"
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     ■作業終了時間 記入
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
'　　引数3:実行メニュー名　　'例："省略中"
' +++********************************************************+++
Public Function InputEndSht(shtName As String, strRng As String, _
                            myProcd As String, exeTime As Date)
    Application.ScreenUpdating = True '画面描画再
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With .Range(strRng)
            .Value = myProcd & "完了" & vbCrLf & _
            Format(Now, "yyyy/mm/dd hh:nn") & _
            " 実行時間 " & Format(exeTime, "h: mm: ss")
           .Interior.Color = rgbGhostWhite '淡い グレー
           .Select
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     ■ Endエラーメッセージ 記入
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
'　　引数3:実行メニュー名　　'例："省略中"
' +++********************************************************+++
Public Function InputErrShtEnd(shtName As String, strRng As String, _
                               myProcd As String)
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With .Range(strRng)
            .Select
            .Value = Format(Now, "yyyy/mm/dd hh:nn")
            .Interior.Color = vbRed '背景色赤
            .Value = " エラー終了 " & myProcd
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'      ■ エラーメッセージ 記入
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
'　　引数3:実行メニュー名　　'例："省略中"
' +++********************************************************+++
Public Function InputErrSht(shtName As String, strRng As String, _
                            myProcd As String)
    Application.ScreenUpdating = True '画面描画再開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With .Range(strRng)
            .Value = myProcd & " エラー終了"
            .Interior.Color = rgbLightPink '背景色淡いピンク
            .Select
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'      ■ メッセージレンジにメッセージ入力
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
'　　引数3:実行メニュー名　　'例："省略中"
' +++********************************************************+++
Public Function InputMsg(shtName As String, strRng As String, _
                         myMsg As String)
    Application.ScreenUpdating = True '画面描画再開開
    ThisWorkbook.Activate   
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With .Range(strRng)
            .Value = myMsg
            .Interior.Color = rgbLightPink '背景色淡いピンク
            .Select
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     ■ メッセージレンジを空白にする
'　　引数1:シート名
'　　引数2:範囲　　　　　　　'例："B2"
' +++********************************************************+++
Public Function InputResume(shtName As String, strRng As String)
    Application.ScreenUpdating = True '画面描画再開開
    ThisWorkbook.Activate
    With ThisWorkbook.Worksheets(shtName)
        .Select
        With .Range(strRng)
            .Value = ""
            .Interior.Color = xlNone '背景色無色
            .Select
        End With
    End With
    Sleep 500
    Call exeBreak
End Function
' +++********************************************************+++
'     全シート再計算を走らせないようにするコード
' +++********************************************************+++
Sub SetNotCalcAll()
    Dim i As Long
    Application.StatusBar = "再計算をさせない処理中"
    Application.Calculation = xlCalculationManual
    With ThisWorkbook
        For i = 1 To .Worksheets.Count
            '【Main】シートの場合
            If .Worksheets(i).Name = "Main" Then
                .Worksheets(i).EnableCalculation = True
           '【Main】シート以外の場合
           Else 
               .Worksheets(i).EnableCalculation = False
           End If
       Next i
    End With
End Sub
' +++********************************************************+++
'     全シート計算可能にするコード
' +++********************************************************+++
Sub SetCalcAll()
    Dim i As Long
    Application.StatusBar = "再計算可能に変更処理中"
    Application.Calculation = xlCalculationManual
    With ThisWorkbook
        For i = 1 To .Worksheets.Count
            '【Main】シートの場合
            If .Worksheets(i).Name = "Main" Then
                .Worksheets(i).EnableCalculation = True
            '【Main】シート以外の場合
            Else
                .Worksheets(i).EnableCalculation = True
                '.Worksheets(i).Calculate '場合によって実行
            End If
        Next i
    End With
End Sub

コメント

タイトルとURLをコピーしました