IT

【VBA】便利マクロ

2025年01月06日

①下記コードを、「標準モジュール」にコピペする。
②「開発」タブ→「マクロ」→マクロ名を選択して「実行」

Option Explicit

''' <summary>
''' フォルダ選択→全ファイルA1セル左上表示
''' </summary>
Sub フォルダ選択→全ファイルA1セル左上表示()
    Dim f As String
    Dim d As String
    Dim Wb As Workbook
    ' フォルダ選択ダイアログ
    d = FileDialog()
    If d = "" Then
        ' キャンセル
        Exit Sub
    End If
    d = d & "\"
    f = Dir(d & "*.xls*")
    Do While f <> ""
        ' A1セル左上表示
        Call GoToA1(d & f)
        f = Dir()
    Loop
End Sub

''' <summary>
''' ファイル選択→全シートA1セル左上表示
''' </summary>
Sub ファイル選択→全シートA1セル左上表示()
    Dim f As String
    ' ファイル選択ダイアログ
    f = GetOpenFileName()
    If f = "" Then
        ' キャンセル
        Exit Sub
    End If
    ' A1セル左上表示
    Call GoToA1(f)
End Sub

''' <summary>
''' フォルダ選択→全ファイル倍率統一
''' </summary>
Sub フォルダ選択→全ファイル倍率統一()
    Dim f As String
    Dim d As String
    Dim n As Integer
    ' フォルダ選択ダイアログ
    d = FileDialog()
    If d = "" Then
        ' キャンセル
        Exit Sub
    End If
    n = Application.InputBox(Prompt:="倍率を入力してください。", Type:=1)
    d = d & "\"
    f = Dir(d & "*.xls*")
    Do While f <> ""
        ' 倍率統一
        Call Zoom(d & f, n)
        f = Dir()
    Loop
End Sub

''' <summary>
''' ファイル選択→全シート倍率統一
''' </summary>
Sub ファイル選択→全シート倍率統一()
    Dim f As String
    Dim n As Integer
    ' ファイル選択ダイアログ
    f = GetOpenFileName()
    If f = "" Then
        ' キャンセル
        Exit Sub
    End If
    n = Application.InputBox(Prompt:="倍率を入力してください。", Type:=1)
    ' 倍率統一
    Call Zoom(f, n)
End Sub

''' <summary>
''' A1セル左上表示
''' </summary>
''' <param name="Path">ファイルパス</param>
Sub GoToA1(Path As String)
    ' 変数宣言
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim Shell As Object
    Dim t As Date
    Dim d As Object
    Dim f As Object
    ' ファイル更新日時を保持する
    t = FileDateTime(Path)
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .Cursor = xlWait
    End With
    Set Wb = Workbooks.Open(Path)
    Set Shell = CreateObject("Shell.Application")
    Set d = Shell.Namespace(Wb.Path)
    Set f = d.ParseName(Wb.Name)
    For Each Sh In Wb.Worksheets
        Call Application.Goto(Reference:=Sh.Range("A1"), Scroll:=True)
    Next Sh
    Call Wb.Worksheets(1).Activate
    Call Wb.Save
    Call Wb.Close
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .Cursor = xlDefault
    End With
    ' ファイル更新日時を元に戻す
    f.ModifyDate = t
    ' 変数解放
    Set f = Nothing
    Set d = Nothing
    Set Shell = Nothing
    Set Sh = Nothing
    Set Wb = Nothing
End Sub

''' <summary>
''' 全シート倍率統一
''' </summary>
''' <param name="Path">ファイルパス</param>
''' <param name="n">倍率</param>
Sub Zoom(Path As String, n As Integer)
    ' 変数宣言
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim Shell As Object
    Dim t As Date
    Dim d As Object
    Dim f As Object
    ' ファイル更新日時を保持する
    t = FileDateTime(Path)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set Wb = Workbooks.Open(Path)
    Set Shell = CreateObject("Shell.Application")
    Set d = Shell.Namespace(Wb.Path)
    Set f = d.ParseName(Wb.Name)
    For Each Sh In Wb.Worksheets
        ActiveWindow.Zoom = n
    Next Sh
    Call Wb.Worksheets(1).Activate
    Call Wb.Save
    Call Wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ' ファイル更新日時を元に戻す
    f.ModifyDate = t
    ' 変数解放
    Set f = Nothing
    Set d = Nothing
    Set Shell = Nothing
    Set Sh = Nothing
    Set Wb = Nothing
End Sub

''' <summary>
''' ファイル選択ダイアログ
''' </summary>
''' <returns>ファイルパス</returns>
Function GetOpenFileName() As String
    Dim f As String
    f = Application.GetOpenFileName(FileFilter:="Excel,*.xls*")
    If f <> "False" Then
        GetOpenFileName = f
    End If
End Function

''' <summary>
''' フォルダ選択ダイアログ
''' </summary>
''' <returns>フォルダパス</returns>
Function FileDialog() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            FileDialog = .SelectedItems(1)
        End If
    End With
End Function

Option Explicit

''' <summary>
''' フォルダ選択→全ファイル同じマクロ実行
''' </summary>
Sub フォルダ選択→全ファイル同じマクロ実行()
    Dim f As String
    Dim d As String
    Dim Wb As Workbook
    ' フォルダ選択ダイアログ
    d = FileDialog()
    If d = "" Then
        ' キャンセル
        Exit Sub
    End If
    d = d & "\"
    f = Dir(d & "*.xls*")
    Do While f <> ""
        Call 共通マクロ(d & f)
        f = Dir()
    Loop
End Sub

''' <summary>
''' ファイル選択→全シート同じマクロ実行
''' </summary>
Sub ファイル選択→全シート同じマクロ実行()
    Dim f As String
    ' ファイル選択ダイアログ
    f = GetOpenFileName()
    If f = "" Then
        ' キャンセル
        Exit Sub
    End If
    Call 共通マクロ(f)
End Sub

''' <summary>
''' 共通マクロ
''' </summary>
''' <param name="Path">ファイルパス</param>
Sub 共通マクロ(Path As String)
    ' 変数宣言
    Dim Wb As Workbook
    Dim Sh As Worksheet
    Dim LastRow As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .Cursor = xlWait
    End With
    Set Wb = Workbooks.Open(Path)
    For Each Sh In Wb.Worksheets
        ' ------------------------------------------------------------
        If Sh.Name = "1_画面項目試験 " Then
           Sh.Range("C3").Value = "=COUNTA($G$9:$G$999)"
           Sh.Range("C4").Value = "=COUNTIF($K$9:$K$999, ""○"") + COUNTIF($N$9:$N$999, ""○"")"
           LastRow = Sh.Range("F" & Rows.Count).End(xlUp).Row + 1
           If LastRow > 9 Then
            Call Sh.Range(Sh.Cells(LastRow, 1), Sh.Cells(Rows.Count, Columns.Count)).Clear
           End If
        End If
        If Sh.Name = "2_機能試験" Then
           Sh.Range("C3").Value = "=COUNTA($F$9:$F$999)"
           Sh.Range("C4").Value = "=COUNTIF($J$9:$J$999, ""○"") + COUNTIF($M$9:$M$999, ""○"")"
           LastRow = Sh.Range("E" & Rows.Count).End(xlUp).Row + 1
           If LastRow > 9 Then
            Call Sh.Range(Sh.Cells(LastRow, 1), Sh.Cells(Rows.Count, Columns.Count)).Clear
           End If
        End If
        If Sh.Name = "3_DB更新試験" Then
           Sh.Range("C3").Value = "=COUNTA($K$9:$K$999)"
           Sh.Range("C4").Value = "=COUNTIF($O$9:$O$999, ""○"") + COUNTIF($R$9:$R$999, ""○"")"
           LastRow = Sh.Range("G" & Rows.Count).End(xlUp).Row + 1
           If LastRow > 9 Then
            Call Sh.Range(Sh.Cells(LastRow, 1), Sh.Cells(Rows.Count, Columns.Count)).Clear
           End If
        End If
        ' ------------------------------------------------------------
    Next Sh
    Call Wb.Worksheets(1).Activate
    Call Wb.Save
    Call Wb.Close
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .Cursor = xlDefault
    End With
    ' 変数解放
    Set Sh = Nothing
    Set Wb = Nothing
End Sub

コメント