New-B03

2025.12.08

NewBaseMacro(2025)

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

' +++********************************************************+++
'    ファイルをリンク更新なしで開く（読み取りではない）
' +++********************************************************+++
Sub openFile()

    Dim filePath As String
    Dim FileFullPath As String
    Dim fName As String
    Dim strPass As String
    Dim IsOpen As Boolean
    Dim wb As Workbook
    Dim OpenBook As Workbook

    On Error GoTo openFile_Err

    Call SetObject
    Call StopUpdating
    IsOpen = False

    filePath = ThisWorkbook.Path & "\"

    '指定ファイルの情報を取得
    With wsCtrl1
        If Application.Caller = "OpenFile1" Then
            filePath = filePath & Trim(.Cells(8, 5))
            fName = Trim(.Cells(10, 5))
            strPass = Trim(.Cells(8, 6))
        ElseIf Application.Caller = "OpenFile2" Then
            filePath = filePath & Trim(.Cells(16, 5))
            fName = Trim(.Cells(18, 5))
            strPass = Trim(.Cells(16, 6))
        End If
    End With

    FileFullPath = filePath & "\" & fName

    'すでに開かれているか確認
    For Each wb In Workbooks
        If wb.Name = fName Then
            MsgBox fName & ": 同名ファイルを既に開いています。" & vbCrLf & _
                   "処理を終了します。", vbExclamation
            GoTo openFile_Exit
        End If
    Next wb

    'ファイル名が空でない場合
    If fName <> "" Then
        If Dir(FileFullPath, vbNormal) = "" Then
            MsgBox "ファイルが存在しません。" & vbCrLf & _
                   "処理を終了します。", vbExclamation
            GoTo openFile_Exit
        End If

        '他のユーザーが使用中か確認
        If IsFileInUse(FileFullPath) Then
            MsgBox "ファイルは他のユーザーによって使用中です。" & vbCrLf & _
                   "読み取り専用で開かれる可能性があります。", vbExclamation
        End If

        'リンク更新なしで開く
        Set OpenBook = Workbooks.Open(FileFullPath, ReadOnly:=False, _
                                      UpdateLinks:=0, Password:=strPass)
    Else
        MsgBox "ファイル名が不明です。" & vbCrLf & _
               "処理を終了します。", vbExclamation
        GoTo openFile_Exit
    End If

openFile_Exit:
    On Error Resume Next
    Call ReSetObject
    Call Updating
    Exit Sub

openFile_Err:
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            DoEvents
            Resume
        End If
    Else
        MsgBox "実行時エラー：" & Err.Number & vbCrLf & _
               Err.Description & vbCrLf & _
               "処理を終了します。", vbExclamation
    End If
    Resume openFile_Exit

End Sub

'================================================
'    ファイルが使用中かどうかを確認する関数
'================================================
Function IsFileInUse(ByVal filePath As String) As Boolean
    Dim ff As Integer
    On Error Resume Next
    ff = FreeFile
    Open filePath For Binary Access Read Write Lock Read Write As #ff
    If Err.Number <> 0 Then
        IsFileInUse = True
    Else
        IsFileInUse = False
        Close #ff
    End If
    On Error GoTo 0
End Function
' +++********************************************************+++
'    ファイルを読み取り専用・リンク更新なしで開く
' +++********************************************************+++
Sub openFile_ReadOnly()

    Dim filePath As String
    Dim FileFullPath As String
    Dim fName As String
    Dim strPass As String
    Dim IsOpen As Boolean
    Dim wb As Workbook
    Dim OpenBook As Workbook

    On Error GoTo openFile_Err

    '静かな準備
    Call SetObject
    Call StopUpdating
    IsOpen = False

    filePath = ThisWorkbook.Path & "\"

    '指定ファイルの情報を取得
    With wsCtrl1
        If Application.Caller = "OpenFile1" Then
            filePath = filePath & Trim(.Cells(8, 5))
            fName = Trim(.Cells(10, 5))
            strPass = Trim(.Cells(8, 6))
        ElseIf Application.Caller = "OpenFile2" Then
            filePath = filePath & Trim(.Cells(16, 5))
            fName = Trim(.Cells(18, 5))
            strPass = Trim(.Cells(16, 6))
        End If
    End With

    FileFullPath = filePath & "\" & fName

    'すでに開かれているか確認
    For Each wb In Workbooks
        If wb.Name = fName Then
            MsgBox fName & ": 同名ファイルを既に開いています。" & vbCrLf & _
                   "処理を終了します。", vbExclamation
            GoTo openFile_Exit
        End If
    Next wb

    'ファイル名が空でない場合
    If fName <> "" Then
        If Dir(FileFullPath, vbNormal) = "" Then
            MsgBox "ファイルが存在しません。" & vbCrLf & _
                   "処理を終了します。", vbExclamation
            GoTo openFile_Exit
        End If

        '読み取り専用・リンク更新なしで開く
        Set OpenBook = Workbooks.Open(FileFullPath, ReadOnly:=True, _
                                      UpdateLinks:=0, Password:=strPass)
    Else
        MsgBox "ファイル名が不明です。" & vbCrLf & _
               "処理を終了します。", vbExclamation
        GoTo openFile_Exit
    End If

openFile_Exit:
    On Error Resume Next
    Call ReSetObject
    Call Updating
    Exit Sub

openFile_Err:
    If Err.Number = 18 Then
        If MsgBox("マクロを終了しますか?", vbYesNo) = vbNo Then
            DoEvents
            Resume
        End If
    Else
        MsgBox "実行時エラー：" & Err.Number & vbCrLf & _
               Err.Description & vbCrLf & _
               "処理を終了します。", vbExclamation
    End If
    Resume openFile_Exit

End Sub
' +++********************************************************+++
'     全シート再計算を走らせないようにするコード
' +++********************************************************+++
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
'********************************************************
'    全シートを再計算可能に設定する
'    ・EnableCalculation を True に
'    ・Main シートも含めて全体を整える
'********************************************************
Sub SetCalcAll()
    Dim i As Long

    '進行状況をステータスバーに表示
    Application.StatusBar = "再計算可能に変更処理中"

    '計算モードを手動に（処理速度配慮）
    Application.Calculation = xlCalculationManual

    With ThisWorkbook
        For i = 1 To .Worksheets.Count
            With .Worksheets(i)
                '全シートに対して再計算可能に設定
                .EnableCalculation = True

                '必要に応じて即時再計算（コメントアウト）
                '.Calculate
            End With
        Next i
    End With
End Sub
'*****************************************************
'    全シートの再計算を抑制するためのコード
'    ・Excel全体の計算モードを「手動」に設定
'    ・特定シート（"Main"）のみ計算を許可
'    ・その他のシートは計算を無効化
'*****************************************************
Sub notCalcAll()
    Dim i As Long

    'Excelアプリケーション全体の計算モードを「手動」に設定
    Application.Calculation = xlCalculationManual
    '※必要に応じて以下を有効化すれば「自動計算」に戻せます
    'Application.Calculation = xlCalculationAutomatic

    '各ワークシートに対して処理を実行
    For i = 1 To ThisWorkbook.Worksheets.Count
        With Worksheets(i)
            '"Main"シートのみ計算を許可
            If .Name = "Main" Then
                .EnableCalculation = True
                '※必要なら以下で即時計算も可能
                '.Calculate
            Else
                'その他のシートは計算を無効化
                .EnableCalculation = False
            End If
        End With
    Next i
End Sub

コメント

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