【エクセルVBAマクロ配布】書類作成を自動化して業務効率アップ｜無料ツール

Sub フォルダ作成()
    Dim mainFolder As String
    mainFolder = GetFolderSelection() & "DefaultMainFolderName" & "\"
    
    ' ダイアログでキャンセルされた場合は終了
    If mainFolder = "DefaultMainFolderName\" Then Exit Sub
    
    Dim subFolders() As String
    subFolders = Split("SubFolder1,SubFolder2,SubFolder3,SubFolder4", ",")
    
    CreateFolders mainFolder, subFolders
    MsgBox "フォルダが作成されました", vbInformation, "完了"
End Sub

Function GetFolderSelection() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        .Show
        If .SelectedItems.Count = 1 Then
            GetFolderSelection = .SelectedItems(1) & "\"
        Else
            GetFolderSelection = ""
        End If
    End With
End Function

Sub CreateFolders(mainFolder As String, ByRef subFolders() As String)
    If Dir(mainFolder, vbDirectory) = "" Then
        MkDir mainFolder
    End If
    
    For i = LBound(subFolders) To UBound(subFolders)
        Dim folderPath As String
        folderPath = mainFolder & subFolders(i) & "\"
        If Dir(folderPath, vbDirectory) = "" Then
            MkDir folderPath
        End If
    Next i
End Sub

DefaultMainFolderName

SubFolder1,SubFolder2,SubFolder3,SubFolder4

フォルダを選択してください

Sub CreateDefaultFolders()
Dim mainFolder As String
mainFolder = GetFolderSelection() & "DefaultMainFolderName" & "\"
If mainFolder = "DefaultMainFolderName\" Then Exit Sub
Dim subFolders() As String
subFolders = Split("SubFolder1,SubFolder2,SubFolder3,SubFolder4", ",")
CreateFolders mainFolder, subFolders
MsgBox "フォルダが作成されました", vbInformation, "完了"

Function GetFolderSelection()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "フォルダを選択してください"
.Show
If .SelectedItems.Count = 1 Then
GetFolderSelection = .SelectedItems(1) & "\"
Else
GetFolderSelection = ""
End If
End With

Sub CreateFolders(mainFolder As String, ByRef subFolders() As String)
If Dir(mainFolder, vbDirectory) = "" Then
MkDir mainFolder
End If
For i = LBound(subFolders) To UBound(subFolders)
Dim folderPath As String
folderPath = mainFolder & subFolders(i) & "\"
If Dir(folderPath, vbDirectory) = "" Then
MkDir folderPath
End If
Next i

Sub 原本をコピーして保存()

    Dim ExcelApp As Object
    Dim OriginalWb As Object
    Dim NewWb As Object
    Dim NewFilePath As String
    Dim FileDialog As Object

    ' エラーハンドリングの設定
    On Error GoTo ErrorHandler

    ' Excelアプリケーションを非表示で起動
    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.Visible = False

    ' オリジナルのExcelファイルを開く
    Set OriginalWb = ExcelApp.Workbooks.Open("C:\path\to\your\original\file.xlsx") ' ファイルのパスを変更する

    ' オリジナルのシートを新しいワークブックにコピー
    OriginalWb.Sheets.Copy
    Set NewWb = ExcelApp.ActiveWorkbook

    ' 保存ダイアログを設定
    Set FileDialog = ExcelApp.FileDialog(2) ' 2は「名前を付けて保存」のダイアログを示す
    FileDialog.InitialFileName = "C:\path\to\your\default\directory\default_filename.xlsx" ' 初期ディレクトリとファイル名を設定

    ' 保存ダイアログを表示
    If FileDialog.Show = -1 Then
        NewFilePath = FileDialog.SelectedItems(1)
        ' Excel形式で新しいファイルとして保存
        NewWb.SaveAs FileName:=NewFilePath, FileFormat:=51 ' 51はxlsx形式を示す
    Else
        GoTo CleanUp ' キャンセルされた場合の処理へ
    End If

    ' 処理の終了前のクリーンアップ
CleanUp:
    OriginalWb.Close False ' オリジナルのファイルを保存せずに閉じる
    If ExcelApp.Visible = False Then ExcelApp.Quit ' Excelアプリケーションを終了
    Exit Sub

    ' エラーハンドリング
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical, "エラー"
    Resume CleanUp

End Sub

Sub 原本をコピーして保存()

    Dim ExcelApp As Object
    Dim OriginalWb As Object
    Dim NewWb As Object
    Dim NewFilePath As String
    Dim FileDialog As Object

    ' エラーハンドリングの設定
    On Error GoTo ErrorHandler

    ' Excelアプリケーションを非表示で起動
    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.Visible = False

    ' オリジナルのExcelファイルを開く
    Set OriginalWb = ExcelApp.Workbooks.Open("C:\path\to\your\original\file.xlsx") ' ファイルのパスを変更する

    ' オリジナルのシートを新しいワークブックにコピー
    OriginalWb.Sheets.Copy
    Set NewWb = ExcelApp.ActiveWorkbook

    ' 保存ダイアログを設定
    Set FileDialog = Application.FileDialog(2) ' 2は「名前を付けて保存」のダイアログを示す
    FileDialog.InitialFileName = "C:\path\to\your\default\directory\default_filename.xlsx" ' 初期ディレクトリとファイル名を設定

    ' 保存ダイアログを表示
    If FileDialog.Show = -1 Then
        NewFilePath = FileDialog.SelectedItems(1)
        ' Excel形式で新しいファイルとして保存
        NewWb.SaveAs FileName:=NewFilePath, FileFormat:=51 ' 51はxlsx形式を示す
    Else
        GoTo CleanUp ' キャンセルされた場合の処理へ
    End If

    ' 処理の終了前のクリーンアップ
CleanUp:
    OriginalWb.Close False ' オリジナルのファイルを保存せずに閉じる
    If ExcelApp.Visible = False Then ExcelApp.Quit ' Excelアプリケーションを終了
    Exit Sub

    ' エラーハンドリング
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical, "エラー"
    Resume CleanUp

End Sub

C:\path\to\your\original\file.xlsx

FileFormat:=51

On Error GoTo ErrorHandler

Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False

Set OriginalWb = ExcelApp.Workbooks.Open("C:\path\to\your\original\file.xlsx")

OriginalWb.Sheets.Copy
Set NewWb = ExcelApp.ActiveWorkbook

Set FileDialog = ...
FileDialog.Show

NewWb.SaveAs Filename:=NewFilePath, FileFormat:=51

OriginalWb.Close False

MsgBox "エラーが発生しました: " & Err.Description, vbCritical, "エラー"

Sub メール作成()
    ' 必要なオブジェクトを定義
    Dim OutApp As Object
    Dim OutMail As Object
    Dim FileDialog As Office.FileDialog
    Dim i As Integer

    On Error GoTo ErrorHandler ' エラーハンドリング開始

    ' Outlookのオブジェクトを生成
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' ファイル選択ダイアログを初期化
    Set FileDialog = Application.FileDialog(1) ' 1 = msoFileDialogOpen
    With FileDialog
        .Title = "添付するファイルを選択してください"
        .AllowMultiSelect = True
        .InitialFileName = "C:\Documents\"

        ' ファイルが選択された場合のみ添付処理を実行
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                OutMail.Attachments.Add .SelectedItems(i)
            Next i
        End If
    End With

    With OutMail
        ' メールの設定
        .To = "example@example.com"
        .Subject = "テストメールの件名"
        .Body = "こんにちは、" & vbNewLine & _
                "これはテストメールです。" & vbNewLine & _
                "よろしくお願いいたします。" & vbNewLine
        .Display
    End With

ProcedureExit:
    ' オブジェクトを解放
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set FileDialog = Nothing

    MsgBox "完了しました", vbInformation ' 完了メッセージを表示
    Exit Sub ' 通常終了

ErrorHandler:
    ' エラーが発生した場合の処理
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
    Resume ProcedureExit ' オブジェクト解放と完了メッセージを表示するための処理にジャンプ
End Sub

example@example.com

テストメールの件名

こんにちは、...

C:\Documents\

Dim OutApp As Object
Dim OutMail As Object
Dim FileDialog As Office.FileDialog
Dim i As Integer

On Error GoTo ErrorHandler

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

コード内のWith FileDialog ... End Withブロック

コード内のWith OutMail ... End Withブロック

Set OutMail = Nothing
Set OutApp = Nothing
Set FileDialog = Nothing

MsgBox "完了しました", vbInformation

コード内のErrorHandler:ラベル以下の部分