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