[Excelマクロ]プロシージャ／関数集

業務でたまにExcelマクロを作りますが、たまに作る分、毎度同じような「プロシージャ／関数」を作っている気がするので、メモとして残しておこうかと思います。

そのまま「標準モジュール」にコピペし、他のプロシージャからcallして使います。

Excelファイルを開く1(sub)

' Excelファイルを開く'
Sub OpenBook(BookFullPath As String)

    Dim BookName As String
    Dim wb As Workbook
    
    ' ファイルの存在チェック'
    BookName = Dir(BookFullPath)
    If BookName = "" Then
        MsgBox BookFullPath & "は存在しません。" & vbCrLf & "ファイルのパス／ファイル名を確認してください。", vbExclamation
        End
    End If
    
    ' 既に開いているかチェック'
    For Each wb In Workbooks
        If wb.Name = BookName Then
            MsgBox BookName & "を既に開いています。" & vbCrLf & "閉じてからマクロを実行してください。", vbExclamation
            End
        End If
    Next wb
    
    ' ブックを読み取り専用で開き非表示にする'
    Application.ScreenUpdating = False
    Workbooks.Open FileName:=BookFullPath, ReadOnly:=True
    Workbooks(BookName).Activate
    ActiveWindow.Visible = False

End Sub

Excelファイルを開く2(function)

'Excelファイルを開く
Function OpenBook(BookFullPath As String)

    Dim bookName As String
    Dim wb As Workbook
    
    ' ファイルの存在チェック'
    bookName = Dir(BookFullPath)
    If bookName = "" Then
        OpenBook = ""
        Exit Function
    End If
    
    ' 既に開いているかチェック'
    For Each wb In Workbooks
        If wb.Name = bookName Then
            MsgBox bookName & "を既に開いています。" & vbCrLf & "閉じてからマクロを実行してください。", vbExclamation
            End
        End If
    Next wb
    
    ' ブックを読み取り専用で開き非表示にする'
    Application.ScreenUpdating = False
    Workbooks.Open Filename:=BookFullPath, ReadOnly:=True
    Workbooks(bookName).Activate
    ActiveWindow.Visible = False
    
    OpenBook = bookName

End Function

Excelファイルを閉じる

' Excelファイルを閉じる'
Sub CloseBook(BookName As String)

    Application.DisplayAlerts = False
    Workbooks(BookName).Close
    Application.DisplayAlerts = True

End Sub

シートの存在チェック

'シートの存在チェック'
Function sheetExist(ByVal WorkSheetName As String) As Boolean

    Dim sht As Worksheet
    
    For Each sht In ActiveWorkbook.Worksheets
    
        If sht.Name = WorkSheetName Then
            sheetExist = True
            Exit Function
        End If
    Next sht
    
    sheetExist = False
End Function

フォルダを作成する

' DLL宣言
#If Win64 Then
  ' 64Bitの場合
  Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As LongPtr
#Else
  ' 32Bitの場合
  Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#End If

' フォルダを作成する'
Sub MakeDir(TargetPath As String)
    
    Dim result As Boolean
    result = MakeSureDirectoryPathExists(TargetPath)
    
    If Not result Then
        MsgBox "フォルダの作成に失敗しました。処理を終了します。"
        End
    End If

End Sub

追記

当初、Declare宣言文を以下のように設定していたが、32bit EXCELでしか動かず64bit EXCELではエラーとなってしまうため以下のように修正した。

修正前）

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

修正後）

#If Win64 Then
  ' 64Bitの場合
  Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As LongPtr
#Else
  ' 32Bitの場合
  Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
#End If

フルパスファイル名からファイル名のみ切り出す

' フルパスファイル名からファイル名のみを取得する'
Function getFileNameFromFullpath(Fullpath As String, Optional OS As String)

    If (OS = "L") Then
        getFileNameFromFullpath = Right(Fullpath, Len(Fullpath) - InStrRev(Fullpath, "/"))
    Else
        getFileNameFromFullpath = Right(Fullpath, Len(Fullpath) - InStrRev(Fullpath, "\"))
    End If

End Function

文字列操作

前方切り出し

' 【関数】「substring + separator +・・・」の文字列からsubstringのみ切り出す
'
Function getSubstring(inputString As String, separator As String)

    Dim hitPosition As Integer
    hitPosition = InStr(inputString, separator)
    
    If (hitPosition = 0) Then
        ' separatorが見つからなければ入力文字列をそのまま返す
        getSubstring = inputString
    Else
        ' separatorが見つかればseparatorより前の文字列を返す
        getSubstring = Left(inputString, hitPosition - 1)
    End If

End Function

後方切り出し

' 【関数】「・・・ + separator + substring」の文字列からsubstringのみ切り出す
'
Function getBackwardSubstring(inputString As String, separator As String)

    Dim hitPosition As Integer
    hitPosition = InStr(Trim(inputString), separator)
    
    If (hitPosition = 0) Then
        ' separatorが見つからなければ入力文字列をそのまま返す
        getBackwardSubstring = inputString
    Else
        ' separatorが見つかればseparatorより後の文字列を返す
        getBackwardSubstring = Right(Trim(inputString), Len(Trim(inputString)) - hitPosition)
    End If

End Function