A#06 Excelマクロの使い方、自作ツール紹介【VBA】

Public Sub MakeDefault()

    '** アクティブなブック内の全シートを指定した倍率にしてA1セルを選択し、
    '** 一枚目のシートを表示するサブプロシージャ


    Application.ScreenUpdating = False      '画面の更新を抑制（高速化）
    On Error Resume Next                    'エラーを無視
    
    Dim zoom As String
    Dim sheet As Object     'ループ中に処理対象となるシートの変数
    
    
    Rem シートの倍率を入力
    Call DataInput(zoom, "シートの倍率を入力", 80)
    If zoom = "" Then Exit Sub
    
    Rem 一番先頭のシートから順にループ処理を行う
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Activate                          '対象のシートをアクティブにする
        ActiveSheet.Range("A1").Select          'シートのA1を選択する
        ActiveWindow.zoom = CInt(zoom)          '拡大倍率を設定する
        ActiveWindow.ScrollColumn = 1           'スクロールを左上に
        ActiveWindow.ScrollRow = 1
    
    Rem 次のシートを処理対象にする
    Next sheet
    
    Rem 一番先頭のシートをアクティブにする
    Sheets(1).Select  

End Sub

Private Sub DataInput(x As Variant, message As String, message2 As String)

    '** ダイアログボックスで変数の値(Str型)を入力するサブプロシージャ
    
    Rem        x：変数（文字列型）
    Rem  message：ダイアログボックスのタイトル
    Rem message2：デフォルトの入力文字
    
    Dim flg_if As Boolean
    
    flg_if = False
    Do
        x = InputBox(message, Default:=message2)
        If StrPtr(x) = 0 Then       ' キャンセル時に終了
            MsgBox "Canceled.", vbExclamation
            Exit Sub
        ElseIf x = "" Then          '値を入力しないでOKボタンを押した場合，再Loopへ
            MsgBox message, vbExclamation
        ElseIf x <> "" Then
            flg_if = True           '入力があった場合おわり
        End If
    Loop Until flg_if = True
    

End Sub

Public Sub QuickClear()

    '** 選択したセルをフォント色「自動」+ 塗りつぶしなしに
    '** cnrl + q
    With Selection.Font
        .ColorIndex = xlAutomatic
        .Bold = False
        .Italic = False
        .Underline = False
        .Strikethrough = False
    End With
    Selection.Interior.ColorIndex = xlNone
    
End Sub

Public Sub GetSheetNames()

    Rem 開いているエクセルのシート名一覧を取得（アクティブなシートに書き込み）
    
    Dim vbm As VbMsgBoxResult
    Dim mysheet As Worksheet
    Dim myRow As Long
    
    vbm = MsgBox("シート名一覧を取得します。", vbOKCancel)
    If vbm = vbCancel Then
        MsgBox "Canceled.", vbExclamation
        Application.DisplayAlerts = False       '保存時の表示off
        Exit Sub
    End If
    
    Worksheets.Add After:=Worksheets(Worksheets.count)
    myRow = 1
    For Each mysheet In Worksheets
        ActiveSheet.Cells(myRow, 1).Value = mysheet.Name
        myRow = myRow + 1
    Next
    
    MsgBox "Finished."
    
End Sub

Public Sub GetFileName()

    Rem フォルダ内の指定した拡張子のファイル名一覧を取得

    Dim Path As String
    Dim ext As String
    Dim buf As String
    Dim cnt As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象ファイルの入ったフォルダを選択"
        .Show
        Path = .SelectedItems(1)
    End With
    
    ext = InputBox("ファイル名を取得する拡張子を入力してください。" & vbNewLine & "（「.」は不要）", "フォルダ内指定した拡張子のファイル名一覧を取得", "xls*")
    If ext = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If
    
    Worksheets.Add After:=Worksheets(Worksheets.count)
    buf = Dir(Path & "\" & "*." & ext)
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
    Loop
    
    MsgBox "Finished."
    
End Sub

Public Sub ConvertExtension()
    
  Rem 対象フォルダ内の指定の拡張子を任意の拡張子に変更
    
    Dim vbm As VbMsgBoxResult
    Dim oldExt As String
    Dim newExt As String
    Dim saveDir As String
    Dim oldFName As String
    Dim newFName As String
    
    vbm = MsgBox("対象フォルダ内の拡張子を変更します。" & vbNewLine & "（データは上書きされます）", vbOKCancel)
    If vbm = vbCancel Then
        MsgBox "Canceled.", vbExclamation
        Application.DisplayAlerts = False       '保存時の表示off
        Exit Sub
    End If

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択"
        If .Show = 0 Then
            MsgBox "Canceled.", vbExclamation
            Exit Sub
        End If
        saveDir = .SelectedItems(1) & "\\"
    End With

    oldExt = InputBox("変更前の拡張子を入力してください。" & vbNewLine & " （「.」は不要 ） ", "変更前の拡張子を入力（データは上書きされます）", "txt")
    If oldExt = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If
    
    newExt = InputBox("変更後の拡張子を入力してください。" & vbNewLine & " （「.」は不要 ）", "変更後の拡張子を入力（データは上書きされます）", "csv")
    If newExt = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If


    oldFName = Dir(saveDir & "*" & oldExt)
    
    Do While Len(oldFName) <> 0
        oldFName = saveDir & oldFName
        newFName = _
            Left(oldFName, Len(oldFName) - Len(oldExt)) & newExt
        
        FileCopy oldFName, newFName
        Kill oldFName
        oldFName = Dir()
    Loop
    
    MsgBox "Finished."
    
End Sub

Sub SaveImageForExcel()

    Rem 指定したフォルダ内のExcelの画像をImageフォルダ内に保存する。
    
    'Application.ScreenUpdating = False
    
    Dim targetPath, imagePath, destPath As String
    Dim targetFile As String
    Dim oldExt, newExt As String
    Dim newName As String
    Dim zipFile As String
    Dim psCommand As String 'PowerShellのコマンドレット組み立て
    Dim wsh As Object 'Shellオブジェクト
    Dim FSO As Object
    Dim result As Integer 'PowerShellのコマンドレット実行結果
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象エクセルの入ったフォルダを選択"
        .Show
        targetPath = .SelectedItems(1)
    End With
    
    Rem 保存用フォルダ作成
    imagePath = targetPath & "\" & "Image"
    If Dir(imagePath, vbDirectory) = "" Then MkDir imagePath
    
    targetFile = Dir(targetPath & "\" & "*.xls*")
    Do While targetFile <> ""
                      
        Rem 拡張子をzipに変換したデータをImageフォルダに保存
        oldExt = "xlsx"
        newExt = "zip"
        newName = Left(targetFile, Len(targetFile) - Len(oldExt) - 1) '拡張子変換後のファイル名
        zipFile = imagePath & "\" & newName & "." & newExt
        FileCopy targetPath & "\" & targetFile, zipFile 'zipをImageへ保存
        
        Rem zipを展開
        '展開用フォルダ作成(ハイフンでエラー?)
        destPath = imagePath & "\" & newName
        MkDir destPath
        '実行するPowerShellのコマンドレットを組み立て
        psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Expand-Archive -Path " & zipFile & " -DestinationPath " & destPath ' & "-Force"
        'Shellオブジェクトを作成する
        Set wsh = CreateObject("WScript.Shell")
        'PowerShellのコマンドレットを実行
        result = wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)
        Set wsh = Nothing
        Kill zipFile
              
        Rem \xl\mediaを各フォルダに移動、名前をExcelと合わせる
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.MoveFolder destPath & "\xl\media", imagePath & "\media"
        Call FSO.DeleteFolder(destPath, True) ' 指定したパスのフォルダを削除
        Set FSO = Nothing
        Name imagePath & "\media" As destPath
        
        targetFile = Dir()
    Loop
    
    
    MsgBox "Finished."

End Sub