VBAについて包括的説明がされているHPは多くあるのですが、ある時から検索にヒットしなくなったりすることが多発したので、個人的によく使うテンプレートを書き溜めます。

１．定数の宣言とスコープ

・プロシージャ内で有効

対象プロシージャの一番上で宣言

・モジュール内で有効

対象モジュールの一番上で宣言

Option Explicit
Const int最終列 As Integer = 50
---------------------------------------
Private Sub CommandButton1_Click()
    Const int開始行 As Integer = 123
End Sub
---------------------------------------

・すべてのモジュールで有効

!!! 【重要】Publicは標準モジュールのみで宣言可 !!!

Public Const DB接続文字列 As string = "123ABC"

２．シート関連

・他のシートの指定

    Dim ws As Worksheet
    Set ws = Worksheets("名簿")
    
　　Set ws = Nothing

・ガサッとクリア

【自シートの場合】書式設定済セルを含む一番下の行まで行ごと削除
　　10行目から削除したい行が始まる場合↓

    '1)フィルタの解除
    'フィルタが掛かったままだと削除残しが発生する為、ここで解除。
    If Me.FilterMode Then Me.ShowAllData
  
    '2)シートのデータを削除する
    '書式設定済セルを含む一番下の行、一番右の列を調べる。
    Dim MaxRow As Long 
    Dim MaxCol As Long
    With ActiveSheet.UsedRange
        MaxRow = .Rows(.Rows.Count).Row
        MaxCol = .Columns(.Columns.Count).Column
    End With

    'ヘッダーを消さない様にMaxRowの最低値(削除開始行)を設定する。
    If MaxRow < 10 Then MaxRow = 10

    '[Case1]MaxRowまで選択して行毎削除する場合。
    Rows("10:" & MaxRow).Delete Shift:=xlUp

    '[Case2]MaxRowまでのRangeを指定して削除する場合。
    Range(Cells(10, 40), Cells(MaxRow, 44)).Delete Shift:=xlUp

【他シートの場合】書式設定済セルを含む一番下の行まで行ごと削除

    '転記先シートのオブジェクト化
    Dim ws As Worksheet
    Set ws = Worksheets("他のシート")

    '1)フィルタの解除
    'フィルタが掛かったままだと削除残しが発生する為、ここで解除。
    If ws.FilterMode Then ws.ShowAllData
  
    '2)書式設定済セルを含む一番下の行、一番右の列を調べる。
    Dim MaxRow, MaxCol As Long
    
    MaxRow = ws.Rows(ws.Rows.Count).Row
    MaxCol = ws.Columns(ws.Columns.Count).Column
    
    '3)ヘッダーを消さない様にMaxRowの最低値(削除開始行)を設定する。
    If MaxRow < 5 Then MaxRow = 5

    '4)MaxRowまで選択して削除！
    ws.Rows("5:" & MaxRow).Delete Shift:=xlUp

    Set ws = Nothing  'オブジェクトの削除

・一番下の値有りのセルまでクリア

    Dim MaxRow As Long
    MaxRow = Cells(Rows.Count, 1).End(xlUp).Row  '1列目の最も下の場合

    'エリアを指定して、値、式をクリアする場合、
    Range(Cells(1, 1), Cells(MaxRow, 6)).Value = ""

    'エリアを指定して、値、式をクリアする場合、
    Range(Cells(1, 1), Cells(MaxRow, 6)).ClearContents
    
    'エリアを指定して、書式、値、式をクリアする場合、
    Range(Cells(1, 1), Cells(MaxRow, 6)).Clear

    '【便利】
    'エリアを指定して、がさっと全部削除して、下方のセルを繰り上げる方法
    'こうすれば列で設定した書式は維持され、指定エリアの文字・書式が削除される。
    Range(Cells(1, 1), Cells(MaxRow, 6)).Delete Shift:=xlUp

・フィルタ解除

    'フィルタが掛かったままだと削除残しが発生することあり。
    If Me.FilterMode Then Me.ShowAllData

・書式/罫線

    '.ShrinkToFit
    Me.Range(Cells(10, 2), Cells(50, 20)).ShrinkToFit = True
    '寄せ
    Me.Range(Cells(10, 2), Cells(50, 20)).HorizontalAlignment = xlLeft 'その他；xlCenter、xlRight
    '数値
    Me.Range(Cells(10, 2), Cells(50, 20)).NumberFormatLocal = "#,###"  '123,456
    Me.Range(Cells(10, 2), Cells(50, 20)).NumberFormatLocal = "0.0"   '15.0、 15.6、0.0
    '文字列
    Me.Range(Cells(10, 2), Cells(50, 20)).NumberFormatLocal = "@"
    '罫線設定
    Range(Cells(2, 1), Cells(2, 10)).Borders(xlEdgeBottom).LineStyle = xlContinuous  
    
    '5列目を文字列化
    Me.Columns(5).NumberFormatLocal = "@"
    '6列目を日付でフォーマット指定
    Me.Columns(6).NumberFormatLocal = "yyyy/mm/dd"
    
    '全シートを文字列化
    Me.Columns.NumberFormatLocal = "@"

・色

　　計算式はこれ⇒　R+G×256+B×256×256
　　好きな色はこれ↓

    Public Const 薄墨 As Long = 15461355
    Public Const 薄桜 As Long = 16763135
    Public Const 薄菊 As Long = 6619135
    Public Const 薄藤 As Long = 16769505

　　ColorIndexはこれ↓

・列の折畳/複数列の指定

Private Sub CheckBoxAAA_Click()
    '列の折り畳み
    If CheckBoxAAA.Value = True Then
        Range(Columns(10), Columns(35)).Select  '【ポイント】複数列の指定
        Selection.EntireColumn.Hidden = True    '隠す
    Else
        Range(Columns(10), Columns(35)).Select
        Selection.EntireColumn.Hidden = False   '見せる
    End If
End Sub

・IME無効　（強制的に）

    '指定のセルを、IME無効にする。
    With Me.Cells(1, 7).Validation
        .Delete
        .Add Type:=xlValidateInputOnly
        .IMEMode = xlIMEModeDisable
    End With

・A1形式⇒R1C1形式への変換

　　　素人さんに「R1C1形式で列番号を指定してね」とお願いするのは困難。
　　　そこで、AH等のアルファベット文字列を列番号(整数)に変換するFunctionを作った。

Private Function 列名変換A1_R1C1(ByVal A1 As String)
    '列名をA1形式からR1C1形式に変換する。
    '変換できない場合は、-1を返す。
    '[引数例]
    '   "A"、"AC"等のシートに表示されてる通りの半角アルファベット(複数文字OK)
    '[変換例]
    '   A⇒1
    '   Z⇒26
    '   AA⇒27
    
    Dim i As Long
    Dim col As Long
    Dim ASCIIコード As Long
    
    col = 0
    For i = 1 To Len(A1)

        ASCIIコード = Asc(Mid(A1, i, 1))  '１文字づつ変換する。
        Debug.Print ("ASCIIコード:" & ASCIIコード)
        
        If ASCIIコード >= 65 And ASCIIコード <= 90 Then 'A～Zであることを確認する。
            'A～Zである。
            col = col + (ASCIIコード - 64) + (25 * (i - 1)) '先の文字の数値に加算していく。
        Else
            'A～Z以外なのでNG ⇒ 終了！
            MsgBox "【エラー発生】" & vbCrLf & "列番号指定にA～Z以外の文字が含まれています。", vbCritical
            列名変換A1_R1C1 = -1
            Exit Function
        End If

    Next i

    列名変換A1_R1C1 = col

End Function

３．セル書込みの高速化

10万行(10列)の値をセルに書込む。

・一番遅い方法

1セルずつ書き込む　⇒　17秒

    Dim i As Long
    Dim k As Long
    
    Dim startTime As Double
    Dim endTime As Double
    
    startTime = Timer
    
    For i = 0 To 99999
        For k = 0 To 9
            Me.Cells(1 + i, 1 + k).Value = i + k
        Next k
    Next i
    
    endTime = Timer
    Me.Cells(1, 11).Value = CInt((endTime - startTime)) & "秒"

・画面リフレッシュの一時停止

画面リフレッシュ停止/再開の利用　⇒　17秒　（あまり変わらない？）

    Dim i As Long
    Dim k As Long
    
    Dim startTime As Double
    Dim endTime As Double
    
    Application.ScreenUpdating = False '----------------------------------画面リフレッシュ停止
    startTime = Timer
    
    For i = 0 To 99999
        For k = 0 To 9
            Me.Cells(1 + i, 1 + k).Value = i + k
        Next k
    Next i
    
    endTime = Timer
    Application.ScreenUpdating = True '----------------------------------画面リフレッシュ再開
    
    Me.Cells(1, 11).Value = CInt((endTime - startTime)) & "秒"

・動的2次元配列を使う１(超高速！)

一旦、ArrayListに値を取込み（1列データを_で結合し、ArrayListにAddする。）
その後、ArrayListを2次元配列に移し替え、シートに2次元配列と同じRangeを指定して代入する。
　　⇒　2秒　（ゴチャゴチャしてても、超早っ！）

    '[参照設定 / ArrayList用] mscorlib

    Dim i As Long
    Dim k As Long
    
    Dim startTime As Double
    Dim endTime As Double

    Dim rowData As String           '1行のデータを_で結合する。
    Dim arryList As New ArrayList   'rowDataを蓄積する為のArrayList
    
    startTime = Timer
    
    'モトネタをarryListに代入する------------------------------------
    For i = 0 To 99999
        rowData = ""
        For k = 0 To 9
            rowData = rowData & CStr(i + k) & "_"
        Next k
        
        '最後の_を抜く
        rowData = Left(rowData, Len(rowData) - 1)
        
        arryList.Add (rowData)  'arryList
    Next i
    
    '2次元配列定義しarryListの要を代入する---------------------------
    Dim rows As Long
    rows = arryList.Count

    Dim 配列() As Variant
    ReDim 配列(rows, 10)     '2次元配列の再定義
    
    Dim splitted As Variant
    
    For i = 0 To 99999
        splitted = Split(arryList(i), "_")  '1行のデータをスプリットする。
        For k = 0 To 9
             配列(i, k) = splitted(k)       '2次元配列に代入する。
        Next k
    Next i
    
    'シートに書込み--------------------------------------------------
    Me.Range(Cells(1, 1), Cells(rows, 10)).Value = 配列

    '経過時間書込み--------------------------------------------------
    endTime = Timer
    Me.Cells(1, 11).Value = CInt((endTime - startTime)) & "秒"

・動的2次元配列を使う２　/Transpose関数【参考】

　２次元配列に値を代入し、それと同じサイズのRangeに代入する。
　【重要】
　　 ①動的2次元配列は1次元目のインデックスは変更できません。
　　 ②.Transpose関数で1次元と2次元を入れ替える！（但し、最大値はあるようだ。）

そう、Transpose関数が扱える要素数に最大値があって、環境によっても異なるそうな…
予め要素数が確定する場合は、１回のRedimで要素数の次元をrow,colに合わせて(シートの表示方向に合わせて)確定し、値を代入する方が楽チンです。
下記サンプルは、都度要素数を増やすので、最後に次元を入れ替えています。

    
    '一旦この動的配列(2次元)にデータを格納する。
    Dim Data() As Variant

    Dim i As Long
    
    i = 0
    Do While i < 100

        'Preserve：格納済データを温存しつつ、要素数を増やす。但し増やせるのは２次元のみ。
        ReDim Preserve Data(3, i + 1)

        '[注意]
        ' ・配列の添え字は0始まり。
        ' ・１次元を増やすことが出来ないので、１次元と２次元がシートとは逆になってしまう!
        Data(0, i) = i + 1
        Data(1, i) = (i + 1) * 10
        Data(2, i) = (i + 1) * 100
        
        i = i + 1
    Loop
    
    '【重要】1次元と2次元を入れ替える！
    Data = WorksheetFunction.Transpose(Data)
    
    '値をシートに表示
    Me.Range(Cells(1, 1), Cells(i + 1, 3)) = Data

４．長～い処理関連

・[Esc]キー押下で処理中断

Public Sub AAA関数()
    '定数xlErrorHandlerを指定すると、強制的にエラーを発生させます。
    '[Esc]キー押下時のエラー番号は「18」。
    
    Application.EnableCancelKey = xlErrorHandler 'エラーを発生させる。
    On Error GoTo MyErr
    
    '長～い処理

Exit Sub
MyErr:
    
    If err.Number = 18 Then
        MsgBox ("[Esc]キーが押されました。処理を中断します。")
    Else
        MsgBox "エラーが発生しました" & vbCrLf & _
            Err.Description, vbCritical
    End If
    
    'リセット関連が有ればここに記述…

End Sub

５．関数

・MsgBox関数　Yes/No確認、vbCritical(重大エラー)

    'Yes/No確認------------------------------------
    Dim Answer As Variant
    Answer = MsgBox("処理しますか…云々", vbYesNo + vbQuestion, "処理する？")

    If Answer = vbNo Then    'Noを選択した場合
        Exit Sub
    End If

    '重大エラー-----------------------------------
    MsgBox "エラーです。" & vbCrLf & "○○してください。" & vbCrLf & "処理を中断します。", _
           vbCritical + vbOKOnly, "重大エラー"

・Split関数

    Dim str As String
    str = "abc_def_ghi"
    
    Dim splitted As Variant
    
    splitted = Split(str, "_")
    
    Debug.Print splitted(0)
    Debug.Print splitted(1)
    Debug.Print splitted(2)

    For k = 0 To UBound(splitted)
        Debug.Print splitted(k)
    Next k

・Fromat関数、日付計算

   Dim 日付str As String
   Dim 日付date As Date
   Dim 日数差 As Integer

   日付str = Format(Now, "yyyy/mm/dd")   '"2020/01/01"
   
   日付date = DateAdd("m", 3, Now)                         '3ヶ月後
   日付date = Format(DateAdd("m", 1, Now), "yyyy/mm/01")   '翌月1日
   日付date = DateAdd("d", -1, 日付date)                   '当月末日

   日数差 = DateDiff("d", Now, 日付date)                   '本日～当月末日

・四捨五入、切り上げ、切り捨て

    i = Round(3.141592, 1)                    '→3.1【銀行丸め】特殊なので使わない
    i = WorksheetFunction.Round(3.141592, 1)  '→3.1 学校で習う四捨五入

    i = WorksheetFunction.RoundUp(3.141592, 1)    '→3.2 切り上げ
    i = WorksheetFunction.RoundDown(3.141592, 1)  '→3.1 切り捨て

６．Dictionary

・オブジェクトの作成(３種類)

    'ツールバーの参照設定を使って「Microsoft Scripting Runtime」を参照する場合
    'こっちで行きましょう。以下の１行でも２行でも同じ。
    
        '１行の書き方
        Dim dicA As New Dictionary
    
        '２行の書き方
        Dim dicB As Dictionary
        Set dicB = New Dictionary
    
    'コードで参照設定する場合
    'この場合はインテリセンス機能を利用出来ません。
        Dim dicC As Object
        Set dicC = CreateObject("Scripting.Dictionary")

・値(key,value)の代入と削除、For Each

    Dim key As String
    Dim value As String
    key = "リンゴ"
    value = "赤"

    dicA(key) = value    '代入

    Dim curKey As Variant
    For Each curKey In dicA
        Debug.Print curKey
        Debug.Print dicA(curKey)
    Next

    dicA.Remove ("リンゴ")  'キーを指定して削除
    dicA.RemoveAll  '全削除

・DictionaryのKey昇順　　

　メソッドとして用意してもらいです(TT)

Public Sub DicKey昇順(ByRef dic As Scripting.Dictionary)
    '------------------------------------------------------------------
    '引数として渡されたDictionaryをkey昇順に並び替える
    '[流れ]
    '  ArrayListクラスのSortメソッドで昇順に並べ替え、新規のDictionaryに追加する。
    '　最後に、引数として渡されたDictionaryにコピーする。
    '
    '　注意：Keyを強制的に文字列と認識させる場合はこちら　⇒　※
    '
    '------------------------------------------------------------------
    '// .NET FrameworkのArrayListクラスを利用する
    Dim aryList As Object   '// ArrayList
    Set aryList = CreateObject("System.Collections.ArrayList")

    '先ず引数dicのkeyを、ArrayListに移す。
    Dim curKey As Variant
    'Dim curKey as String   '←※
    For Each curKey In dic
        aryList.Add curKey
    Next curKey

    aryList.Sort   '移し替えたkeyをソート!!!これ便利!!!

    Dim sortedDic As Scripting.Dictionary
    Set sortedDic = CreateObject("Scripting.Dictionary")
    
    sortedDic.CompareMode = dic.CompareMode '比較モードをコピーする。⇒【お勉強】

    '新しい順番でsortedDicに代入する。
    Dim tmp As Variant
    'Dim tmp As String   '←※
    For Each tmp In aryList
        sortedDic.Add tmp, dic.Item(tmp)
    Next tmp
    
    'コピー(全削除＆代入)
    dic.RemoveAll       '全削除(不要？)
    Set dic = sortedDic 'コピー！

    Set aryList = Nothing
    Set sortedDic = Nothing
    
    '【お勉強】DictionaryのCompareModeについて
    '
    '定数                  値   説明
    'vbUseCompareOption    -1   Option Compare ステートメントの設定を使用
    'vbBinaryCompare        0   バイナリ比較(大文字小文字区別する)  ←規定値
    'vbTextCompare          1   バイナリ比較(大文字小文字区別しない)
    'vbDatabaseCompare      2   Microsoft Access のみ
End Sub

・DictionaryのValue並べ替え

【注意】DictinaryにValueをセットする際、文字列型/数値型の変数に一旦代入して、型を明示してください。

Public Sub DicValue並替(ByRef dicIn As Dictionary, ByVal 方向 As String)
    '--------------------------------------------------------------------------
    '[機能]
    '   DictioanryのValueに従い、降順/昇順に並べ替える。
    '
    '[引数の説明]
    '   dicIn (Dictinary型): 並び替えるDictinary
    '   方向(String型)　   : 並び替える方向。値は"昇順"or"降順"
    '
    '【注意】
    '   ・DictinaryにValueをセットする際、文字列型/数値型の変数に一旦代入して、
    '   　型を明示してください。
    '   ・定義が曖昧な"00012"の様な「前ゼロ有り文字列」のvalueは、数値型として処理されます。
    '--------------------------------------------------------------------------

    Dim i As Long
     
    Dim dicCopy As New Dictionary   '引数のDictionaryのコピー
    Dim dicSorted As New Dictionary 'Value降順に並べ直したDictionary
    
    Dim minValue As Variant
    Dim minKey As Variant

    Dim maxValue As Variant
    Dim maxKey As Variant
    
    Dim curKey As Variant
    
    '一旦コピー(安全の為？)
    Set dicCopy = dicIn
    
    If 方向 = "昇順" Then   '----------------------------------------------------------------------

        'valueの最大値のkey-valueのセットを求める。
        i = 0
        For Each curKey In dicCopy
            If i = 0 Then
                '初回なので初期値を代入する。
                maxValue = dicCopy(curKey)
                maxKey = curKey
            Else
                If maxValue <= dicCopy(curKey) Then
                    maxValue = dicCopy(curKey)
                    maxKey = curKey
                End If
            End If
            i = i + 1
        Next
        
        Debug.Print "maxValue:" & maxValue
        Debug.Print "maxKey  :" & maxKey

        'これから並べ替える。
        For i = 1 To dicCopy.Count
        
            minValue = maxValue '[初期値]最大値をセットする。
    
            '最小値値調査
            For Each curKey In dicCopy
                '最小値を保存する。
                If minValue >= dicCopy(curKey) Then
                    minKey = curKey
                    minValue = dicCopy(curKey)
                End If
            Next
            
            '元のDictonaryから最大値のkey-valueセットを削除する。⇒【ポイント】これで次のループではこのセットは出てこない。
            dicCopy.Remove (minKey)
    
            '最大値をdicSortedに保存する。
            dicSorted(minKey) = minValue
    
        Next i
        
        Set dicIn = dicSorted  '【完成】引数のDictinaryにセット
    
    ElseIf 方向 = "降順" Then   '------------------------------------------------------------------
    
        'valueの最小値のkey-valueのセットを求める。
        i = 0
        For Each curKey In dicCopy
            If i = 0 Then
                '初回なので初期値を代入する。
                minValue = dicCopy(curKey)
                minKey = curKey
            Else
                If minValue >= dicCopy(curKey) Then
                    minValue = dicCopy(curKey)
                    minKey = curKey
                End If
            End If
            i = i + 1
        Next
        
        Debug.Print "minValue:" & minValue
        Debug.Print "minKey  :" & minKey

        'これから並べ替える。
        For i = 1 To dicCopy.Count
        
            maxValue = minValue '[初期値]最小値をセットする。
    
            '最小値値調査
            For Each curKey In dicCopy
                '最小値を保存する。
                If maxValue <= dicCopy(curKey) Then
                    maxKey = curKey
                    maxValue = dicCopy(curKey)
                End If
            Next
            
            '元のDictonaryから最大値のkey-valueセットを削除する。⇒【ポイント】これで次のループではこのセットは出てこない。
            dicCopy.Remove (maxKey)
    
            '最大値をdicSortedに保存する。
            dicSorted(maxKey) = maxValue
    
        Next i
        
        Set dicIn = dicSorted  '【完成】引数のDictinaryにセット
    
    Else    '--------------------------------------------------------------------------------------
        Set dicIn = dicCopy  '【エラー】そのまま戻す。
    End If

End Sub

７．パス、ログインユーザ関連

    dim Winログインユーザ名 As String
    dim 利用PC As String
    dim 起動パス As String

    'Winログイン名の取得
    Winログインユーザ名 = Environ("USERNAME")

    'PC名の取得
    利用PC = Environ("COMPUTERNAME")
    
    '起動パスの取得
    起動パス = ThisWorkbook.Path

    'ツールバーの参照設定を使って「Windows Script Host Object Model」を参照しない場合
    'デスクトップのパスを調べる------------------------------
    Dim WshShell As Variant
    Set WshShell = CreateObject("Wscript.Shell")
    
    Dim Path As String
    Path = WshShell.SpecialFolders("Desktop") & "\"
    
    Debug.Print (Path)
    
    Set WshShell = Nothing
        
    'ログインユーザ/PC名を調べる----------------------------------
    Dim WshNetwork As Object
    Set WshNetwork = CreateObject("WScript.Network")
      
    Dim ユーザ名 As String
    ユーザ名 = WshNetwork.UserName
    
    Dim PC名 As String
    PC名 = WshNetwork.ComputerName
    
    Debug.Print (ユーザ名 & vbCrLf & PC名)

    Set WshNetwork = Nothing

８．ActveXコントールを指定の位置に戻す

ActveXコントールの欠点は、サイズや位置、フォントサイズが勝手に変わってしまうこと。
これを強制的に指定の位置に戻します。

・呼出側

    'CommandButton1変換
    Call ActiveXControl位置規制(Me.CommandButton1, Me.Range(Me.Cells(5, 3), Cells(7, 5)), 15, 15, 5, 5, 10)

・関数側

引数イメージ：

Public Sub ActiveXControl位置規制( _
                                    obj As CommandButton, _
                                    r As Range, _
                                    m_Left As Integer, _
                                    m_Right As Integer, _
                                    m_Top As Integer, _
                                    m_Bottom As Integer, _
                                    fontSize As Integer _
                                    )
    '**************************************************************************
    '[処理内容]
    '
    '引数に従い、ActiveXControlの表示位置を規制する
    'すべて参照渡し
    '
    'obj:       対象オブジェクト
    'r:         対象オブジェクトをはめ込むRange
    'm_Left:    同Rangeと対象オブジェクトの左マージン
    'm_Right:   同Rangeと対象オブジェクトの右マージン
    'm_Top:     同Rangeと対象オブジェクトの上部マージン
    'm_Bottom:   同Rangeと対象オブジェクトの下部マージン
    'fontSize:  フォントサイズ
    '
    '**************************************************************************

    '対象オブジェクトのプロパティ変更------------------------------------------
    obj.Left = r.Left + m_Left
    obj.Top = r.Top + m_Top

    obj.Width = r.Width - m_Left - m_Right
    obj.Height = r.Height - m_Top - m_Bottom
    
    obj.Font.Size = fontSize
    
End Sub

２０．データベース問合せ(select文)

・基本形

参照設定はこちら：　Microsoft ActiveX Data Objects 2.8 Library

Private Sub CommandButton1_Click()
    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim SQL As String

    Dim i As Integer

    'データベースへの接続 cn
    Set cn = New ADODB.Connection
    cn.Open DB接続文字列   '←接続文字列はどこかで設定してね。

    SQL = "SELECT 社員番号, 氏名, 所属 FROM ..."

    Set rs = New ADODB.Recordset
    rs.Open SQL, cn

    If rs.BOF = True Then  'データが無い場合の処理

    Else 'データが有る場合の処理
        i = 0
        Do
            Me.Cells(1 + i, 1).value = rs.Fields("社員番号").value
            Me.Cells(1 + i, 2).value = rs.Fields("氏名").value
            Me.Cells(1 + i, 3).value = rs.Fields("所属").value

            rs.MoveNext
            i = i + 1
        Loop Until rs.EOF = True
    End If

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

Exit Sub
err:  'エラー処理
    'Recordsetの状態を確認し、クローズ
    If rs.State <> ADODB.adStateClosed Then
        rs.Close
    End If
    Set rs = Nothing

    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

    MsgBox err.Description

End Sub

・CopyFromRecordsetで表示(便利♪)

Cells(10, 1)が表示するRangeの左上とすると…

    If rs.BOF = True Then  'データが無い場合の処理
    Else 'データが有る場合の処理
        Me.Cells(10, 1).CopyFromRecordset Data:=rs
    End If

・GetRowsを使うと…遅いぞ

Private Sub CommandButton1_Click()
    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim SQL As String
    
    Dim rowCnt As Long
    Dim colCnt As Long
    
    Dim data() As Variant '問合せ結果を格納する配列


    'データベースへの接続 cn
    Set cn = New ADODB.Connection
    cn.Open DB接続文字列   '←接続文字列はどこかで設定してね。

    SQL = "SELECT 社員番号, 氏名, 所属 FROM ..."

    Set rs = New ADODB.Recordset
    rs.Open SQL, cn, adOpenStatic   '←.GetRows使う場合は追加設定要

    If rs.BOF = True Then  'データが無い場合の処理

    Else 'データが有る場合の処理
            'フィールド数とレコード数を取得
            rowCnt = rs.RecordCount
            colCnt = rs.Fields.Count
            
            ReDim data(colCnt - 1, rowCnt - 1) '要素数再定義
            data = rs.GetRows   'レコードセットの内容を変数に格納
            
            data = WorksheetFunction.Transpose(data) '【重要】1次元と2次元を入れ替える！
            
            Range(Cells(1, 1), Cells(rowCnt, colCnt)) = data 'シートに転記
    End If

    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing

Exit Sub
err:   'エラー処理
    MsgBox err.Description
    
    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

End Sub

２１．データベース書換え(I/U/D文)

Private Sub CommandButton1_Click()
    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim SQL As String

    Set cn = New ADODB.Connection '接続
    cn.Open DB接続文字列   '←接続文字列はどこかで設定してね。

    cn.BeginTrans     '<<<<<<<<<<<<<<<<<<<<<<トランザクション開始！！！
    
    'Delete
    SQL = "delete from テーブル名 where … ;"  ';で繋ぐこともできる
    'Insert
    SQL = SQL & "insert into テーブル名 …"
    cn.Execute (SQL)

    cn.CommitTrans    '<<<<<<<<<<<<<<<<<<<<<<トランザクション正常終了！！！

    cn.Close
    Set cn = Nothing

Exit Sub
err:   'エラー処理
    cn.RollbackTrans  '<<<<<<<<<<<<<<<<<<<<<<トランザクション異常終了！！！

    MsgBox err.Description

    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

End Sub

２２．データベースのストアド起動

２３．Accessファイルに対して一括実行

【概要等】
　・アクセスの場合、；で繋いだSQL文を渡せないので、代替関数を考えた。
　・トランザクション付き
　・[参照設定]　⇒　Microsoft ActiveX Data Objects x.x Library　が必要。

１） SQLを ;(セミコロン) で繋いだ文字列を引数として受け取る場合

　　但し、Stringの最大文字数を超えるとらエラーになる。

    Public Const FileName As String = "ファイル名.accdb" 'Accessのファイル名
    Public Const DB接続文字列 As String = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source= ぱす\" & FileName & ";"

Function SQL実行(SQL As String) As String
    ';で繋がれたSQLを引数として受け取り、;でSplitして1文づつ実行する。
    'エラーが発生した場合は、エラー発生元となったSQLを返す。
    '最後に;があれば1文でも処理可能

    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim 分解済SQL As String     'SQLを;でSplitした後の個々のSQLを格納する。
    Dim 実行情報 As String      '実行直前のSQLを格納する。
    Dim i As Long
    Dim splitted As Variant

    Set cn = New ADODB.Connection '接続
    cn.Open DB接続文字列

    cn.BeginTrans     '<<<<<<<<<<<<<<<<<<<<<<トランザクション開始！！！

    splitted = Split(SQL, ";")

    For i = 0 To UBound(splitted) - 1
        分解済SQL = splitted(i)
        If 分解済SQL = "" Then Exit For
        実行情報 = i + 1 & "回目操作：" & 分解済SQL '実行直前のSQLを格納する。
        cn.Execute (分解済SQL)
    Next i

    cn.CommitTrans    '<<<<<<<<<<<<<<<<<<<<<<トランザクション正常終了！！！

    cn.Close
    Set cn = Nothing
    
    SQL実行 = "OK:" & i & "件実行しました。"
    MsgBox ("正常終了しました。")
    

Exit Function
err:   'エラー処理
    cn.RollbackTrans  '<<<<<<<<<<<<<<<<<<<<<<トランザクション異常終了！！！
    
    SQL実行 = "NG:" & 実行情報
    
    MsgBox err.Description
    MsgBox ("【エラー情報】" & vbCrLf & 実行情報)
    
    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

End Function

２） SQLが格納された１次元配列を引数として受け取る場合

Function SQL実行_配列(sql配列() As String) As String

    '１次元配列に格納されたSQLを引数として受け取り、1文づつ実行する。
    'エラーが発生した場合は、エラー発生元となったSQLを返す。

    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim 分解済SQL As String     'SQLを;でSplitした後の個々のSQLを格納する。
    Dim 実行情報 As String      '実行直前のSQLを格納する。
    
    Dim i As Long

    Set cn = New ADODB.Connection '接続
    cn.Open constDB接続文字列


    cn.BeginTrans     '<<<<<<<<<<<<<<<<<<<<<<トランザクション開始！！！
    
    'Debug.Print ("UBound(sql配列)/最大Index： " & UBound(sql配列))

    For i = 0 To UBound(sql配列)

        実行情報 = i + 1 & "回目操作：" & sql配列(i) '実行直前のSQLを格納する。
        
        'Debug.Print ("i:" & i & "⇒" & sql配列(i))
        
        cn.Execute (sql配列(i))
    Next i
    
    
    cn.CommitTrans    '<<<<<<<<<<<<<<<<<<<<<<トランザクション正常終了！！！

    cn.Close
    Set cn = Nothing
    
    SQL実行_配列 = "OK:" & i & "件実行しました。"
    
    MsgBox ("正常終了しました。")
    

Exit Function
err:   'エラー処理
    cn.RollbackTrans  '<<<<<<<<<<<<<<<<<<<<<<トランザクション異常終了！！！
    
    SQL実行_配列 = "NG:" & 実行情報
    
    MsgBox err.Description
    MsgBox ("【エラー情報】" & vbCrLf & 実行情報)
    
    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

End Function

３） SQLが格納されたArryListを引数として受け取る場合

【注意】ArrayListを使う場合、「参照設定」で mscorlib.dllにチェックを入れること。

呼出側では、動的配列にSQLを代入するより、ArryListに要素としてSQLをAddしていく方が可読性良好。
但し、ArrayListは.netのクラスなので入力支援機能は効かないよ。
なので、バインドはアーリー/レイトのどちらでも構わないかな？

Function SQL実行_ArrayList(sqlList As ArrayList) As String

    'ArrayListに格納されたSQLを引数として受け取り、1文づつ実行する。
    'エラーが発生した場合は、エラー発生元となったSQLを返す。

    On Error GoTo err

    Dim cn As ADODB.Connection
    Dim 分解済SQL As String     'SQLを;でSplitした後の個々のSQLを格納する。
    Dim 実行情報 As String      '実行直前のSQLを格納する。
    
    Dim i As Long
    'Dim splitted As Variant

    Set cn = New ADODB.Connection '接続
    cn.Open constDB接続文字列


    cn.BeginTrans     '<<<<<<<<<<<<<<<<<<<<<<トランザクション開始！！！

    For i = 0 To sqlList.Count - 1

        実行情報 = i + 1 & "回目操作：" & sqlList(i) '実行直前のSQLを格納する。
        
        'Debug.Print ("i:" & i & "⇒" & sqlList(i))
        
        cn.Execute (sqlList(i))
    Next i
    
    
    cn.CommitTrans    '<<<<<<<<<<<<<<<<<<<<<<トランザクション正常終了！！！

    cn.Close
    Set cn = Nothing
    
    SQL実行_ArrayList = "OK:" & i & "件実行しました。"
    
    MsgBox ("正常終了しました。")
    

Exit Function
err:   'エラー処理
    cn.RollbackTrans  '<<<<<<<<<<<<<<<<<<<<<<トランザクション異常終了！！！
    
    SQL実行_ArrayList = "NG:" & 実行情報
    
    MsgBox err.Description
    MsgBox ("【エラー情報】" & vbCrLf & 実行情報)
    
    'Connectionの状態を確認し、クローズ
    If cn.State <> ADODB.adStateClosed Then
        cn.Close
    End If
    Set cn = Nothing

End Function

４） Tableをクリエイト（サンプル）

Private Sub CommandButtonmユーザマスタテーブル作成_Click()

    Dim SQL As String
    Dim tmpSQL As String
    
    SQL = ""

    
    'Dropテーブル
    tmpSQL = ""
    tmpSQL = tmpSQL & "DROP TABLE m_ユーザマスタ;"

    SQL = SQL & tmpSQL
    
    
    'Createテーブル
    tmpSQL = ""
    tmpSQL = tmpSQL & "CREATE TABLE m_ユーザマスタ("
    tmpSQL = tmpSQL & " 表示順 INTEGER NOT NULL DEFAULT 0,"
    tmpSQL = tmpSQL & " 区分 TEXT(4) NOT NULL DEFAULT '',"
    tmpSQL = tmpSQL & " 部 TEXT(2) NOT NULL DEFAULT '',"
    tmpSQL = tmpSQL & " 運用FLG TEXT(1) NOT NULL ,"
    tmpSQL = tmpSQL & " 社員番号 TEXT(5) ,"
    tmpSQL = tmpSQL & " 社員名 TEXT(15) NOT NULL,"
    tmpSQL = tmpSQL & " 更新者 TEXT(10),"
    tmpSQL = tmpSQL & " 更新日時 DATETIME"
    tmpSQL = tmpSQL & " PRIMARY KEY (社員番号)"
    tmpSQL = tmpSQL & ");"

    SQL = SQL & tmpSQL
    
    'SQLを実行する
    Dim result As String
    
    result = SQL実行(SQL)
    Me.Cells(10, 3).value = result


End Sub

２４．Accessファイル(.accdb)の最適化とバックアップ

　参照設定：Microsoft office 15.0 Access database engine Object

    Dim Path_Target As String           '最適化対象のAccessデータベースフォルダパス
    Dim FileName_Target As String       '最適化対象のAccessデータベースファイル名
    
    Dim FileName_Optimized As String    '最適化済のAccessデータベースファイル名
    
    Dim Path_BuckUp As String           'バックアップ用のAccessデータベースフォルダパス
    Dim FileName_BuckUp As String       'バックアップ用のAccessデータベースファイル名
    
    
    '最適化対象のAccessデータベースフォルダパス
    Path_Target = "C:\AAA\データベース置場\"
   
    '最適化対象のAccessデータベースファイル名
    FileName_Target = "DB.accdb"
    
    '最適化済のAccessデータベースファイル名(最適化対象ファイルと同じフォルダに保存する)
    FileName_Optimized = "DB_最適化済.accdb"
    
    'バックアップAccessデータベースフォルダパス
    Path_BuckUp = "C:\AAA\バックアップ置場\"
    
    'バックアップAccessデータベースファイル名
    FileName_BuckUp = "DB_バックアップ" & Format(Now, "yyyymmdd_hhnnss") & ".accdb"


    '最適化実行-----------------------------------------------------------------------------------
    DBEngine.CompactDatabase Path_Target & FileName_Target, Path_Target & FileName_Optimized, DAO.DatabaseTypeEnum.dbVersion120

    '最適化対象のファイルを名称を変更してBackupとして保存-----------------------------------------
    Name Path_Target & FileName_Target As Path_BuckUp & FileName_BuckUp
    
    '最適化済のファイルの名前を元に戻す-----------------------------------------------------------
    Name Path_Target & FileName_Optimized As Path_Target & FileName_Target
    
    '更新日から3ヶ月経過したバックアップファイルを削除する。-------------------------------------
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim fl As Folder
    Set fl = fso.GetFolder(Path_BuckUp) ' フォルダを取得
    
    Dim tmpDate As Date
    
    Dim 削除ファイル数 As Long
    
    Dim f As File
    For Each f In fl.Files ' フォルダ内のファイルを取得
        
            'Debug.Print ("-----")
            'Debug.Print ("f.Name              : " & f.Name)
            'Debug.Print ("f.DateLastModified  : " & f.DateLastModified)
            'Debug.Print ("DateAdd(m, -3, Now) : " & DateAdd("m", -3, Now))
        
        tmpDate = f.DateLastModified
        
        If tmpDate <= DateAdd("m", -3, Now) Then
            Kill Path_BuckUp & f.Name
        End If
    Next
    
    ' 後始末
    Set fso = Nothing

４０．メール送信

　　[参照設定要] Microsoft CDO for Windows 2000 Library

Public Function メール送信( _
                            fromAddress As String, _
                            toAddress As String, _
                            ccAddress As String, _
                            subject As String, _
                            message As String) As String
On Error GoTo Err

    '引数で受け取った情報をメールする。
    
    'Microsoft Collaboration Data Objectsのインスタンスを生成する
    'Set oMsg = CreateObject("CDO.Message")
    
    '↑【注意】レイトバインドでは動かなかったので、アーリーバインドに変更する。
    '          [参照設定]Microsoft CDO for Windows 2000 Library
    
    Dim oMsg As New CDO.message

    With oMsg
    
        .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = xxx
        .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.xxxxxx.co.jp"
        .Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "xxx"
        .Configuration.Fields.Update
        
        ' 送信元メールアドレス
        .From = fromAddress
        ' To送信先メールアドレス
        .To = toAddress
        ' CC送信先メールアドレス
        .cc = ccAddress
        ' 文字コード
        .BodyPart.Charset = "ISO-2022-JP"
        '　メール件名
        .subject = subject
        '　メール本文
        .textbody = message
        
        '送信
        .send
        
    End With
    
    Set oMsg = Nothing
    メール送信 = "OK"

Exit Function
Err:
    
    Set oMsg = Nothing
    メール送信 = "NG/エラー発生"
    
End Function

５０．他ブック操作

・他のブックを開かずに値取得

    Dim i As Long

    Dim xls As New Excel.Application  'エクセルアプリケーションを開き、オブジェクトを変数xlsに代入する。
    Dim wb As Workbook
    Dim pathTarget As String    '読み込むファイルのフルパス
  
    '読み込むファイルのフルパスを設定する。
    pathTarget = ThisWorkbook.path & "\ターゲットブック.xlsx"

    Debug.Print ("ThisWorkbook.path :" & ThisWorkbook.path)
    Debug.Print ("pathTarget        :" & pathTarget)

    
    xls.Visible = False      'エクセル可視/不可視設定
    xls.DisplayAlerts = False      '警告メッセージをオフ
    
    Set wb = xls.Workbooks.Open(Filename:=pathTarget, ReadOnly:=True)    '読み取り専用でブックを開く
    
    '読み取って、自シートに書込む
    Me.Cells(5, 2).Value = wb.Sheets("データ1").Cells(10, 1).Value

    xls.DisplayAlerts = True    '警告メッセージをオン
    xls.Quit                    'Excel終了
    
    Set wb = Nothing
    Set xls = Nothing

・他のブックを開かずに値書込み

    Dim i As Long

    Dim xls As New Excel.Application  'エクセルアプリケーションを開き、オブジェクトを変数xlsに代入する。
    Dim wb As Workbook
    Dim pathTarget As String    '読み込むファイルのフルパス
  
    '読み込むファイルのフルパスを設定する。
    pathTarget = ThisWorkbook.path & "\ターゲットブック.xlsx"

    Debug.Print ("ThisWorkbook.path :" & ThisWorkbook.path)
    Debug.Print ("pathTarget        :" & pathTarget)

    
    xls.Visible = False      'エクセル可視/不可視設定
    xls.DisplayAlerts = False      '警告メッセージをオフ
    
    Set wb = xls.Workbooks.Open(Filename:=pathTarget, IgnoreReadOnlyRecommended:=True)     '書込み可能で開く
    
    '書込み
    wb.Sheets("データ1").Cells(2, 5).Value = "書込んだぜよ！"
    
    '保存
    wb.Save

    xls.DisplayAlerts = True    '警告メッセージをオン
    xls.Quit                    'Excel終了
    
    Set wb = Nothing
    Set xls = Nothing

・他のブックのシートを自ブックにコピーする

    Dim フルパス As String
    Dim シート名 As String
    フルパス = "C:\…\○○○.xlsx"
    シート名 = "××××"
    
    Dim コピー元wb As Workbook

    Application.ScreenUpdating = False '----------------------------------画面リフレッシュ停止

    'コピー元エクセルを開く
    Set コピー元wb = Workbooks.Open(Filename:=フルパス, ReadOnly:=True)    '読み取り専用でブックを開く
    '【注意】Dim xls As New Excel.Application　⇒ xls.Workbooks.Open…とするとエラーになる。
    
    '開いた後になるけど、非表示にする(【注意】非表示でOpenするReadOnlyの様なプロパティ無し)
    Application.Windows(コピー元wb.Name).Visible = False
    
    'コピー元エクセルのシートを、自分のブックの最後にコピーする。
    コピー元wb.Worksheets(シート名).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count)

    'コピー元ブックを保存せずに閉じる。
    コピー元wb.Close SaveChanges:=False

    Set コピー元wb = Nothing  '必ず必要。忘れたらメモリーに残るよ。

    Application.ScreenUpdating = True '----------------------------------画面リフレッシュ再開

５１．ファイル操作

・既存シートを新規ブックとして保存

隠しシート「フォーマットA」シートのコピーを新規ブックのシートとして生成し、同ブックをデスクトップに保存する。

Private Sub CommandButton1_Click()
    On Error GoTo err

    '出力対象のシートのオブジェクト化
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("フォーマットA")   '←コピー元シート

    'デスクトップのパスを調べる---------------------------------------------
    Dim Path As String
    Dim WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    Path = WSH.SpecialFolders("Desktop") & "\"

    'ファイル名の確定-------------------------------------------------------
    Dim FileName As String
    FileName = "新規保存したファイル.xlsx"

    MsgBox ("新規ファイルをデスクトップに出力します。" & vbCrLf & "　パス⇒　" & Path & vbCrLf & "　ファイル名⇒　" & FileName)

    'ファイルチェック-----------------------------------------------------
    '①同一フォルダーに同一ファイル名は存在するのか、②そのファイルは開かれているのかチェック
    '①ファイルは存在するのか？
    If Dir(Path & FileName) = "" Then
        '存在しません。
    Else
        '存在します。ならば…
        '②そのファイルは開かれているか？
        If IsBookOpened(Path & FileName) = True Then
            '開かれています
            MsgBox (FileName & " が開かれています。このファイルを閉じて再度ボタンを押してください。")
            Me.Activate
            Exit Sub
        Else
            '開かれていません
        End If
    End If


    '対象シートのコピーを新規ブックに新シートとして作成する----------------
    ws.Visible = xlSheetVisible        '【重要】隠したままでは、コピーできない！
    ws.Copy                            'ここで新ブックにコピーが出来る。
    
    'シート名を変更する【注意】.CopyしたシートがActiveになっている
    ActiveWorkbook.ActiveSheet.name = "1月売上"


    'ブック(ファイル)を保存する---------------------------------------------
    Dim フルパス As String
    Dim re As Variant
    
    Dim 出力結果 As String
    出力結果 = "NG"

    If ActiveWorkbook.Path = "" Then
        'まだ保存されたことがないブック(パスが保存されていない！)
        
        フルパス = Path & FileName

        If Dir(フルパス) <> "" Then
            '既存ファイル有る!!!
            re = MsgBox("この場所に" & vbCrLf & "  " & FileName & vbCrLf & _
                        "という名前のファイルが既にあります。置き換えますか？", _
                        vbInformation + vbYesNoCancel + vbDefaultButton2)

            If re = vbYes Then
                Application.DisplayAlerts = False   '【!!!ポイント!!!】保存しますかのメッセージを出さない。
                On Error Resume Next '【!!!ポイント!!!】エラー無視!!!

                ActiveWorkbook.SaveAs _
                FileName:=Path & FileName, _
                FileFormat:=xlOpenXMLWorkbook

                On err GoTo err  'エラー対策戻し
                Application.DisplayAlerts = True

                出力結果 = "OK"
            End If
        Else
            '既存ファイル無し!!!
            ActiveWorkbook.SaveAs _
                FileName:=Path & FileName, _
                FileFormat:=xlOpenXMLWorkbook
                
            出力結果 = "OK"
        End If
    Else
        '【注意】今回のケースではここには来ないが残しておく。
        'すでに保存されたブック
        ActiveWorkbook.SaveAs _
            FileName:=Path & FileName, _
            FileFormat:=xlOpenXMLWorkbook
    End If


    Application.DisplayAlerts = False   '【重要】保存しますかのメッセージを出さない。
    ActiveWorkbook.Close
    Application.DisplayAlerts = True    '【重要】戻しておく。

    ws.Visible = xlSheetVeryHidden      '隠しファイルを隠した状態に戻す。
    Set ws = Nothing                    '操作お終い。
    

    Me.Activate                         '呼び出し元のシートをアクティブに。
    
    If 出力結果 = "OK" Then
        MsgBox ("ファイル出力は正常完了しました。")
    Else
        MsgBox ("ファイル出力は失敗しました。")
    End If


Exit Sub
err:
    MsgBox ("エラーが発生しました！")
End Sub


Function IsBookOpened(フルパス As String) As Boolean
    On Error Resume Next
    'ブックが開かれているかどうかを確認する。

    ' 保存済みのブックか判定
    Open フルパス For Append As #1
    Close #1

    If err.Number > 0 Then
        ' 既に開かれている場合 -> True
        IsBookOpened = True
    Else
        ' 開かれていない場合 -> False
        IsBookOpened = False
    End If
End Function

・新規ブックを生成して保存

新規ブックを生成、新規シートに文字代入/書式設定してデスクトップに保存・・・フォーマットシートを作った方が楽チンね。

Private Sub CommandButton1_Click()
    
    Dim FileName As String
    Dim フルパス As String
    Dim i As Integer
    
    '1.デスクトップにファイルを生成する------------------------------------
    'デスクトップのパスを調べる
    Dim Path As String
    Dim WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    Path = WSH.SpecialFolders("Desktop") & "\"
    
    Set WSH = Nothing

    MsgBox ("デスクトップにファイルを作成します。" & vbCrLf & "パス⇒" & Path)
    
    
    Dim newbk As String             '定義
    Workbooks.Add                   '新規にブックを追加
    newbk = ActiveWorkbook.Name     '追加したブックの名前を取得
    Workbooks(newbk).Activate       'アクティブにする

    Dim ws As Worksheet
    Set ws = ActiveWorkbook.Worksheets(1)   '←書込み先の1枚目のシートのオブジェクト化
    
    ws.Name = "1月売上"             'シート名変更
    
    
    '2.シートに書込む----------------------------------------------
    'ヘッダー書込み
    ws.Cells(1, 1).value = "AAA"
    ws.Cells(1, 2).value = "BBB"
    ws.Cells(1, 3).value = "CCC"
    ws.Cells(1, 4).value = "DDD"

    '列の書式設定
    ws.Columns(1).NumberFormatLocal = "@"  '文字列
    ws.Columns(2).NumberFormatLocal = "@"  '文字列
    ws.Columns(3).NumberFormatLocal = "@"  '文字列
    ws.Columns(4).NumberFormatLocal = "@"  '文字列
    
    '列幅
    For i = 5 To 13
        ws.Columns(i).ColumnWidth = 15
    Next i
    

    '列幅の指定(実際にAutoFitするにはデータが入ってから)
    For i = 1 To 2
        ws.Columns(i).AutoFit
    Next i
    
    
    '3.ファイルを保存する。----------------------------------------------------
    'FileNameの確定
    FileName = "2022年度売上" & Format(Now, "yyyymmdd") & ".xlsx"
    
    'ファイルが開かれているか確認
    If IsBookOpen(FileName) Then
        MsgBox (FileName & "がひらかれているので、新規ファイルを保存できません。" & vbCrLf & "ファイルを閉じて再度ボタンを押してください。")
        
        Application.DisplayAlerts = False       '---強制的に上書きするのでアラート不要
        ActiveWorkbook.Close '閉じる
        Application.DisplayAlerts = True        '---アラートを戻す。

        Exit Sub
    Else
        MsgBox (FileName & "　を作成しました。" & vbCrLf & "新規ファイルを保存し閉じます")
    End If
    
    
    '名前を付けて保存
    Application.DisplayAlerts = False       '---強制的に上書きするのでアラート(上書きしてもいいですか？)不要
    フルパス = Path & FileName
    Workbooks(newbk).SaveAs FileName:=フルパス
    Application.DisplayAlerts = True        '---アラートを戻す。


    '閉じる
    Workbooks(FileName).Close

    Set ws = Nothing

End Sub


Function IsBookOpen(ブック名 As String) As Boolean
  '「インストラクタのネタ帳」さんより(感謝)
  Dim bk As Workbook
  IsBookOpen = False

  For Each bk In Workbooks
    If bk.Name = ブック名 Then
      IsBookOpen = True
      Exit For
    End If
  Next

End Function

９０．値変更禁止、だがソート可

決められた範囲のセルの値を変更は禁止だが、ソート・フィルタは自由にしたい。
そんな風にするならVBAでコード書くしかない。
セル上に[CheckBox書換え禁止]を置くこと前提のコードだが、そこはご自由に！

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If CheckBox書換え禁止.Value = True Then
    
        Dim Undo実行 As Boolean
        Undo実行 = False
  
        'Rangeで変更される場合もあるので、
        '選択範囲が書換え禁止範囲に入っているかの確認
        '入っていれば、Undoへ…
        Dim c As Range
        For Each c In Target
            'Debug.Print ("c:" & c.Column)
            If c.Column >= 2 And c.Column <= 5 Then  '書換え禁止範囲の設定(列指定の例)
                Undo実行 = True
            End If
        Next c

        'Undo実行!!!
        If Undo実行 = True Then
                  Application.EnableEvents = False '←イベント停止（Undoでｲﾍﾞﾝﾄが発生しないようにする）
                    Application.Undo        　'１つ前の状態に戻す
                    MsgBox ("書換え禁止セルに書換が発生しましたので、もとに戻しました。" & vbCrLf & "注意してください。")
                  Application.EnableEvents = True  　'←イベント再開（通常状態に戻す）
        End If

    End If

End Sub

９５－１．VBAでRSA暗号のお勉強

[先生]
https://www.comm.tcu.ac.jp/~math/hnakai/infomath/rsa.html
https://fussy.web.fc2.com/algo/algo9-3.htm

[操作とボタンの説明]
1)P,Qの値に素数を手入力します。
2)[公開鍵作成]ボタンを押します。
　⇒R,K1,K2,K3が計算され表示されますが、K3の値が-1の場合は「対象となる値が無い」のでもう一度ボタンを押してください。
3)Cells(19,3)に平文を手入力します。
　【注意】VBAはSJISしか扱えなので、SJISに変換できる文字を入力します。
4)[暗号化]ボタンを押します。
　⇒以下が表示されます。
　・平文をSJISコードに変換し、結合した文字列(半角アンダーバー区切り)
　・それぞれのSJISコードを暗号化した文字列
5)[復号]ボタンを押します。
　⇒以下が表示されます。
　・暗号をSJISコードに戻した文字列
　・SJISコードを平文に戻した文字列

[ポイント]
・素数P,Qを300ぐらいまで大きくすると、公開鍵の計算途中で巨大整数が発生しオーバーフローします。(TT)
・Function 繰返2乗法(...)はオーバーフロー対策ですが限度あります。
・実用されているの素数P,Qは何ケタなんでしょーね？

公開鍵作成

Private Sub 公開鍵作成(ByVal P As Long, _
                       ByVal Q As Long, _
                       ByRef R As Long, _
                       ByRef K1 As Long, _
                       ByRef K2 As Long, _
                       ByRef K3 As Long, _
                       ByRef K2候補列挙 As String)
                       
    '**************************************************************************
    '　秘密鍵PQから、公開鍵K1,K2などを生成する。
    '   [引数]
    '   　P：素数
    '   　Q：素数　(但し、P<Q)
    '   [戻り値]
    '   　R：P-1とQ-1の最小公倍数(公開鍵ではないが秘密)
    '   　K1：P×Q　(但し、暗号化したい数値より大きいこと)
    '   　K2：Rの約数ではない値 (<M?)
    '   　K3：(R×n+1)÷K2　が整数になる整数n。
    '       　K3を求められなかった場合の戻り値を-1とする。
    '   　K2約数列挙:参考の為、K2約数を列挙した文字列を戻す。
    '         例)3,4,6,7,8,9
    '**************************************************************************
    
    Dim i As Long

    'R(P-1とQ-1の最小公倍数)を求める---------------------------------
    R = WorksheetFunction.Lcm((P - 1), (Q - 1))
    
    'K1(P×Q)を求める------------------------------------------------
    K1 = P * Q
    'K2(P-1とQ-1の最小公倍数Rの約数ではない値)を求める---------------
    Dim K2列挙 As String    'K2の候補を列挙した文字列
    For i = 1 To R
        If R Mod i = 0 Then
            '約数
        Else
            '約数でない
            K2列挙 = K2列挙 & CStr(i) & ","
        End If
    Next i
    
    '最後のカンマ取り
    K2列挙 = Left(K2列挙, Len(K2列挙) - 1)
    
    K2候補列挙 = K2列挙
    
    'K2列挙からランダムに選択する。
    '現在日時取得
    Dim t As SYSTEMTIME
    Call GetLocalTime(t)
    Dim m秒 As Long
    m秒 = t.wMilliseconds
        'Debug.Print ("m秒:  " & m秒)
        
    Dim 秒 As Long
    秒 = CLng(Format(Now, "ss"))
        'Debug.Print ("秒:  " & 秒)
        
    Dim 分 As Long
    分 = CLng(Format(Now, "mm"))
        'Debug.Print ("分:  " & 分)
        
    Dim RND1 As Long
    Dim RND2 As Long
    RND1 = CLng(Rnd * 1000)
    RND2 = CLng(Rnd * 1000)
        'Debug.Print ("RND1:  " & RND1)
        'Debug.Print ("RND2:  " & RND2)
    
    Dim ルーレット As Long
    ルーレット = RND1 * RND2 + RND2 * 秒 + m秒 + 分 ^ 2 + 分
        'Debug.Print ("ルーレット:  " & ルーレット)
    
    'K2列挙のスプリット
    Dim splitted As Variant
    splitted = Split(K2列挙, ",")
        'Debug.Print ("splitted.UBound:  " & UBound(splitted))
    
    'K2の決定
    K2 = splitted(ルーレット Mod (UBound(splitted) + 1))

    'K3を求める------------------------------------------------------
    K3 = -1 'K3を求められなかった場合の戻り値を-1にする。
    Dim 計算値 As Double  'Long

    For i = 0 To 100000
        
        計算値 = (R * i + 1) / K2
        
        If CLng(計算値) = 計算値 Then  '計算値と計算値の少数点切り捨てが一致しているなら、整数。
            '割り切れた！
            K3 = (R * i + 1) / K2
            
            Debug.Print ("整数！ i=" & i)
            Debug.Print ("  計算値=" & 計算値)
            
            Exit For
        End If
    Next i

End Sub

暗号化ボタン

Private Sub CommandButton暗号化_Click()
    
    Dim i As Long
    
    Dim K1 As LongPtr
    Dim K2 As LongPtr
    Dim tmpLong As LongPtr
    
    K1 = Me.Cells(13, 5).Value
    K2 = Me.Cells(14, 5).Value

    '平文⇒SJISへ変換------------------------------------------------
    Dim 平文 As String
    平文 = Me.Cells(19, 3).Value
    
    Dim SJIS As String
    Dim 暗号 As String
    
    Dim SJIS単文字Lng As Long
    Dim SJIS単文字 As String
    Dim 暗号単文字 As String
    
    For i = 1 To Len(平文)
        
        SJIS単文字Lng = Asc(Mid(平文, i, 1))
        
        If SJIS単文字Lng < 0 Then
            '2バイト文字
            SJIS単文字 = CStr(SJIS単文字Lng * (-1))
        Else
            '1バイト文字
            SJIS単文字 = CStr(SJIS単文字Lng)
        End If
        
        SJIS = SJIS & SJIS単文字 & "_"
        
        暗号単文字 = 繰返2乗法(SJIS単文字, K2, K1)
        
        Debug.Print ("SJIS⇒暗号:" & SJIS単文字 & " ⇒　" & 暗号単文字)

        暗号 = 暗号 & 暗号単文字 & "_"
        
    Next i
    
    '最後の_削除
    SJIS = Left(SJIS, Len(SJIS) - 1)
    暗号 = Left(暗号, Len(暗号) - 1)
    
    '書込み
    Me.Cells(22, 3).Value = SJIS
    Me.Cells(23, 3).Value = 暗号

End Sub

復号ボタン

Private Sub CommandButton復号_Click()
    
    Dim K1 As Long
    Dim K3 As Long
    
    K1 = Me.Cells(13, 5).Value
    K3 = Me.Cells(16, 5).Value
    
    Dim 暗号 As String
    暗号 = Me.Cells(23, 3).Value
    
    Dim SJIS As String
    
    Dim 平文 As String
    平文 = ""
    
    Dim SJIS単文字 As String
    Dim 暗号単文字 As Long
    
    
    '暗号をスプリットする。
    Dim splitted As Variant
    splitted = Split(暗号, "_")
    
    Dim i As Long
    
    For i = 0 To UBound(splitted)

        暗号単文字 = CLng(splitted(i))
        
        SJIS単文字 = 繰返2乗法(暗号単文字, K3, K1)
        
        SJIS = SJIS & SJIS単文字 & "_"

    Next i
    
    '最後の_削除
    SJIS = Left(SJIS, Len(SJIS) - 1)

    'SJIS書込み
    Me.Cells(26, 3).Value = SJIS
    
    
    'SJIS⇒平文に変換
    Dim splittedSJIS As Variant
    splittedSJIS = Split(SJIS, "_")
    
    Dim SJISコード As Long
    
    
    For i = 0 To UBound(splittedSJIS)
        
        SJISコード = CLng(splittedSJIS(i))
        
        If SJISコード < 300 Then
            平文 = 平文 & Chr(SJISコード)
        Else
            平文 = 平文 & Chr(SJISコード * (-1))
        End If

    Next i
    
    '平文書込み
    Me.Cells(27, 3).Value = 平文

End Sub

繰返2乗法

Function 繰返2乗法(ByVal 底 As Long, ByVal 指数 As Long, ByVal 法 As Long) As Long
    
    '【機能】
    '[底]の[指数]乗を[法]で割った際の余りを返す。

        'Debug.Print ("底  : " & 底)
        'Debug.Print ("指数: " & 指数)
        'Debug.Print ("法  : " & 法)

    Dim i As Long
    Dim 余り As LongPtr
    
    Dim cur値 As Long
 
    余り = 底 Mod 法
    
    If 指数 Mod 2 = 0 Then
        '偶数の場合
        cur値 = 1
    Else
        '奇数の場合
        cur値 = 余り
    End If
    
    
    '【右シフトの方法】
    'bit = Twentyfour \ (2 ^ 1) ' 1 桁右へシフト
    'bit = Twentyfour \ (2 ^ 3) ' 3 桁右へシフト
    
    Dim shiftN As Long
    shiftN = 1
    Do While 指数 \ (2 ^ shiftN) > 0
        
        'modのオーバーフロー回避https://vbabeginner.net/when-mod-operator-overflows/
        余り = (余り * 余り) - Fix((余り * 余り) / 法) * 法
        '余り = (余り * 余り) Mod 法 '【注意】Mod関数が扱える整数はLongまで⇒ボツ
        
        If (指数 \ (2 ^ shiftN)) Mod 2 = 1 Then
            cur値 = (cur値 * 余り) Mod 法
        End If
        
        shiftN = shiftN + 1
    Loop
    
    繰返2乗法 = cur値

End Function

VBAでmSecを使う為に/標準モジュール

'VBAでmSecを表示する為--------------------------------------------------------
Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
'// 64bit版
#If VBA7 And Win64 Then
    Declare PtrSafe Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
'// 32bit版
#Else
    Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
#End If

９５－２．VBAでAES-256暗号のお勉強

暗号化ボタン

Private Sub CommandButton暗号化_Click()
        
    Dim aesKey As String
    Dim iv As String
    Dim 平文 As String
    Dim 暗号文 As String
    
    
    aesKey = Me.Cells(3, 2).Value
    iv = Me.Cells(4, 2).Value
    
    平文 = Me.Cells(7, 2).Value
    
    暗号文 = AesEncrypt(平文, aesKey, iv)
    
    Me.Cells(10, 2).Value = 暗号文
    
End Sub

復号ボタン

Private Sub CommandButton復号_Click()
    Dim aesKey As String
    Dim iv As String
    Dim 平文 As String
    Dim 暗号文 As String
    
    
    aesKey = Me.Cells(3, 2).Value
    iv = Me.Cells(4, 2).Value
    
    暗号文 = Me.Cells(10, 2).Value
    
    平文 = AesDecrypt(暗号文, aesKey, iv)

    Me.Cells(13, 2).Value = 平文
    
End Sub

暗号化/復号ファンクション

'
'AES-256-CBC暗号化
'
Public Function AesEncrypt(plaintext As String, aesKey As String, iv As String) As String
    Dim AES As Object
    Dim utf8 As Object
    Dim cipherBytes() As Byte
    Dim plainBytes() As Byte
 
    Set AES = CreateObject("System.Security.Cryptography.RijndaelManaged")
    Set utf8 = CreateObject("System.Text.UTF8Encoding")
 
    AES.KeySize = 256
    AES.BlockSize = 128
    AES.Mode = 1            'CipherMode.CBC
    AES.Padding = 2         'PaddingMode.PKCS7
    AES.key = utf8.GetBytes_4(aesKey)
    AES.iv = utf8.GetBytes_4(iv)
    plainBytes = utf8.GetBytes_4(plaintext)
 
    cipherBytes = AES.CreateEncryptor().TransformFinalBlock(plainBytes, 0, UBound(plainBytes) + 1)
 
    AesEncrypt = BytesToBase64(cipherBytes)
 
    Set AES = Nothing
    Set utf8 = Nothing
End Function
 
'
'AES-256-CBC復号
'
Public Function AesDecrypt(encryptedString As String, aesKey As String, iv As String) As String
    Dim AES As Object
    Dim utf8 As Object
    Dim encrypted_byte_data() As Byte
    Dim str_byte_data() As Byte
 
    Set AES = CreateObject("System.Security.Cryptography.RijndaelManaged")
    Set utf8 = CreateObject("System.Text.UTF8Encoding")
 
    AES.KeySize = 256
    AES.BlockSize = 128
    AES.Mode = 1            'CipherMode.CBC
    AES.Padding = 2         'PaddingMode.PKCS7
    AES.key = utf8.GetBytes_4(aesKey)
    AES.iv = utf8.GetBytes_4(iv)
 
    encrypted_byte_data = Base64toBytes(encryptedString)
    str_byte_data = AES.CreateDecryptor.TransformFinalBlock(encrypted_byte_data, 0, UBound(encrypted_byte_data) + 1)
 
    AesDecrypt = utf8.GetString(str_byte_data)
 
    Set AES = Nothing
    Set utf8 = Nothing
End Function
 
Function BytesToBase64(varBytes() As Byte) As String
    Dim obj As Object
    Dim elm As Object
 
    Set obj = CreateObject("MSXML2.DomDocument")
    Set elm = obj.CreateElement("base64")
 
    elm.DataType = "bin.base64"
    elm.nodeTypedValue = varBytes
    BytesToBase64 = Replace(elm.Text, vbLf, "") '改行が含まれるので除去
 
    Set obj = Nothing
    Set elm = Nothing
End Function
 
Function Base64toBytes(varStr As String) As Byte()
    Dim obj As Object
    Dim elm As Object
 
    Set obj = CreateObject("MSXML2.DOMDocument")
    Set elm = obj.CreateElement("base64")
 
    elm.DataType = "bin.base64"
    elm.Text = varStr
    Base64toBytes = elm.nodeTypedValue
 
    Set obj = Nothing
    Set elm = Nothing
End Function