マジックナンバーを排除した転記Part2
1 Part１は丸囲みを動かすマクロが出力シートのモジュールにイベントとして記載済のものを流用するため回りくどかったため、今回は入力シートにすべて書きこんでスッキリさせた。
2 シート構成など。
入力シートと出力シート２つ。出力シートは自動給紙設定済と手差し給紙設定済のもの。
入力シート内の左側に入力欄、右側にデータベース部分を配置。
出力シートは既定の印刷帳票。
入力シート左側で縦方向に入力していき、入力完了後Enterを押すだけでデータベース部分へ転記する。
3 コード
Option Explicit
'イベントの途中でエラーになったりステップ実行途中で抜けると、イベント発生不可のままになってしまうので、
'イベントが発生しなくなってしまったらイミディエイトウインドウで Application.EnableEvents = True とする。
'ここは電消入力シートモジュール
'電消入力シート
'入力項目のセルアドレス
Const adrs入力欄_集計年月 = "B2"
Const adrs入力欄_年分 = "C4"
Const adrs入力欄_台帳ER区分 = "C５"
Const adrs入力欄_台帳下4桁 = "C6"
Const adrs入力欄_バッチ下4桁 = "C7"
Const adrs入力欄_有還区分 = "C8"
Const adrs入力欄_SKoku区分 = "C9"
Const adrs入力欄_件数 = "C10"
Const adrs入力欄_誤り有無 = "C11"
Const adrs入力欄_連絡日 = "C12"
Const adrs入力欄_回付日 = "C13"
Const adrs入力欄_転記実行セルの1つ下 = "C15"
'電消入力シート
'データベース部分(一旦の転記してデータを溜めておく部分)
'列記号(columnLetter）ex.F10セルの「F」のこと。
Const Cletterデータベース_入力ID = "F"
Const Cletterデータベース_印刷対象 = "G"
Const Cletterデータベース_集計年 = "H"
Const Cletterデータベース_集計月 = "I"
Const Cletterデータベース_年分 = "J"
Const Cletterデータベース_台帳ER区分 = "K"
Const Cletterデータベース_台帳下4桁 = "L"
Const Cletterデータベース_バッチ下4桁 = "M"
Const Cletterデータベース_有還区分 = "N"
Const Cletterデータベース_SKoku区分 = "O"
Const Cletterデータベース_件数 = "P"
Const Cletterデータベース_誤り有無 = "Q"
Const Cletterデータベース_連絡日 = "R"
Const Cletterデータベース_回付日 = "S"
'セル番地
Const adrsデータベース_基点 = "Ｆ９"
'行番号
Const RNoデータベース_タイトル行番号 = 9
Const RNoデータベース_開始行番号 = 10
'印刷帳票(電消シート、電消手差しシート）
'SK区分の表内の丸囲みを配置するxy座標(自分で調べて数字を決める）
'------------------------------------------------
Const yoko内 = 300: Const yoko訂 = 350
Const tate内 = 150: Const tate訂 = 150
'------------------------------------------------
Const yoko後 = 300: Const yoko修 = 350
Const tate後 = 200: Const tate修 = 200
'------------------------------------------------
'セルアドレス
Const adrs印刷帳票_台帳ER区分 = "M8"
Const adrs印刷帳票_台帳下4桁 = "M10"
Const adrs印刷帳票_連絡日 = "D13"
Const adrs印刷帳票_集計年 = "D14"
Const adrs印刷帳票_集計月 = "F14"
Const adrs印刷帳票_バッチ下4桁 = "D15"
Const adrs印刷帳票_件数 = "E16"
Const adrs印刷帳票_整理年月日 = "D17"
Const adrs印刷帳票_年分 = "D18"
Const adrs印刷帳票_連絡件数 = "E20"
Const adrs印刷帳票_引受日 = "D23"
Const adrs印刷帳票_誤り有無 = "D26"
Const adrs印刷帳票_回付日 = "I13"
'■■■■■セレクションチェンジイベント■■■■■
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'イベント二重起動防止
Application.EnableEvents = False
'シート設定
Dim ws入力 As Worksheet: Set ws入力 = Me
'目的：BackTabボタン、Tabボタンで移動できるようにアクティブセルを制御
'ここはセル番地を直打ちした方が分かり易いと思う
Select Case Target.Address(0, 0)
'BackTab用
Case "B5"
Range("C4").Select
Case "B6"
Range("C5").Select
Case "B7"
Range("C6").Select
Case "B8"
Range("C7").Select
Case "B9"
Range("C8").Select
Case "B10"
Range("C9").Select
Case "B11"
Range("C10").Select
Case "B12"
Range("C11").Select
Case "B13"
Range("C12").Select
Case "B14"
Range("C13").Select
Case "B15"
Range("C14").Select
'Tab用
Case "D４"
Range("C5").Select
Case "D5"
Range("C6").Select
Case "D6"
Range("C7").Select
Case "D7"
Range("C8").Select
Case "D8"
Range("C9").Select
Case "D9"
Range("C10").Select
Case "D10"
Range("C11").Select
Case "D11"
Range("C12").Select
Case "D12"
Range("C13").Select
Case "D13"
Range("C14").Select
Case "D14"
Range("C15").Select
End Select
'目的：入力欄→DBへ1件転記
'「転記実行」と書いてあるセルでEnterキーを押した場合
If Target.Address(0, 0) = adrs入力欄_転記実行セルの1つ下 Then
'「ws入力の入力欄」から「ws入力のDB範囲」へ1件転記する
With ws入力
'注）ループ内で変数宣言しても宣言処理は1回しか実行されないので問題なし
Dim RNo転記先 As Long: RNo転記先 = .Range(Cletterデータベース_年分 & .Rows.Count).End(xlUp).Row + 1
'注）漢数字の〇と記号の〇は違うので全プロシージャで統一しておかないと正しく動作しない
.Range(Cletterデータベース_印刷対象 & RNo転記先).Value = "〇"
.Range(Cletterデータベース_集計年 & RNo転記先).Value = Left(.Range(adrs入力欄_集計年月).Value, 2)
.Range(Cletterデータベース_集計月 & RNo転記先).Value = Right(.Range(adrs入力欄_集計年月).Value, 2)
.Range(Cletterデータベース_年分 & RNo転記先).Value = .Range(adrs入力欄_年分).Value
.Range(Cletterデータベース_台帳ER区分 & RNo転記先).Value = .Range(adrs入力欄_台帳ER区分).Value
.Range(Cletterデータベース_台帳下4桁 & RNo転記先).Value = .Range(adrs入力欄_台帳下4桁).Value
.Range(Cletterデータベース_バッチ下4桁 & RNo転記先).Value = .Range(adrs入力欄_バッチ下4桁).Value
.Range(Cletterデータベース_有還区分 & RNo転記先).Value = .Range(adrs入力欄_有還区分).Value
.Range(Cletterデータベース_SKoku区分 & RNo転記先).Value = .Range(adrs入力欄_SKoku区分).Value
.Range(Cletterデータベース_件数 & RNo転記先).Value = .Range(adrs入力欄_件数).Value
.Range(Cletterデータベース_連絡日 & RNo転記先).Value = .Range(adrs入力欄_連絡日).Value
.Range(Cletterデータベース_回付日 & RNo転記先).Value = .Range(adrs入力欄_回付日).Value
'誤り有無は入力内容を「有」「無」に変換して転記
If .Range(adrs入力欄_誤り有無).Value = 0 Or .Range(adrs入力欄_誤り有無).Value = "" Then
.Range(Cletterデータベース_誤り有無 & RNo転記先).Value = "無"
Else
.Range(Cletterデータベース_誤り有無 & RNo転記先).Value = "有"
End If
'アクティブセルを移動して次件の入力をしやすくする
.Range(adrs入力欄_年分).Select
End With
End If
'イベント起動可に戻す
Application.EnableEvents = True
End Sub
'■■■■■ダブルクリックイベント■■■■■
'ダブルクリックしたセルが特定の範囲にあった場合
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'ダブルクリックしたセルの列記号で場合分け
Select Case Split(Target.Address, "$")(1)
'ダブルクリックしたセルがG列だったら
Case "G"
'ダブルクリックしても編集モードにしない
Cancel = True
'ダブルクリックしたセルの値で場合分け
Select Case Target.Value
'セルの値が空欄だったら”〇”を入力
Case ""
Target.Value = "〇"
'セルの値が”〇”だったら空欄にする
Case "〇", "印刷済"
Target.Value = ""
End Select
'ダブルクリックいたセルがQ列だったら
Case "Q"
'ダブルクリックしても編集モードにしない
Cancel = True
'ダブルクリックしたセルの有と無を相互に入れ替える
Select Case Target.Value
Case "無"
Target.Value = "有"
Case "有"
Target.Value = "有"
End Select
End Select
End Sub
'■■■■■一括印刷ボタン■■■■■
Sub btn電子データ整理表へ転記しながら一括印刷()
Application.EnableEvents = False
'シート設定
Dim ws電消入力 As Worksheet: Set ws電消入力 = ThisWorkbook.Worksheets("電消入力")
Dim ws電消 As Worksheet: Set ws電消 = ThisWorkbook.Worksheets("電消")
Dim ws電消手差し As Worksheet: Set ws電消手差し = ThisWorkbook.Worksheets("電消手差し")
'目的：手差し用紙をセットしたか確認メッセージを表示する
'表示メッセージ内容
Dim m As String: m = ""
m = m & "マイナス(有還区分２）は手差し給紙です。" & vbNewLine
m = m & "手差し用紙をセットしましたか？" & vbNewLine
m = m & "「印刷対象」列に〇が入っている行を印刷します。" & vbNewLine
m = m & "印刷実行しますか？" & vbNewLine
'手差し用紙をセットしていなかったら印刷をキャンセル。ボタン選択のデフォルト位置はキャンセル
If MsgBox(m, vbOKCancel + vbDefaultButton2) = vbCancel Then
MsgBox "印刷をキャンセルします"
Exit Sub
End If
'目的：「転記（DB→出力用帳票へ）して印刷」をループ
Dim R As Long
For R = RNoデータベース_開始行番号 To ws電消入力.Range(Cletterデータベース_印刷対象 & ws電消.Rows.Count).End(xlUp).Row
'印刷対象列に〇がないときは転記と印刷をスキップする
If ws電消入力.Range(Cletterデータベース_印刷対象 & R).Value <> "〇" Then GoTo continueNextFor
'目的：印刷対象シートを決める
'今回は２つの帳票は全く同じだが、手動で給紙方法だけ設定しておく。マクロ実行前に片方を自動給紙、もう片方を手差し給紙で設定保存しておく。
Dim ws印刷対象 As Worksheet
'有還区分が「２」だったら
If ws電消入力.Range(Cletterデータベース_有還区分 & R).Value = 2 Then
Set ws印刷対象 = ws電消手差し
'有還区分が「２」以外なら
Else
Set ws印刷対象 = ws電消
End If
'転記（ＤＢ→出力帳票）して印刷
With ws印刷対象
'丸囲みを動かす
'丸囲みの図形名はマクロ記録で動かして調べること
Select Case ws電消入力.Range(Cletterデータベース_有還区分 & R).Value
Case 0
.Shapes.Range(Array("Oval 1")).Left = yoko内
.Shapes.Range(Array("Oval 1")).Top = tate内
Case 1
.Shapes.Range(Array("Oval 1")).Left = yoko後
.Shapes.Range(Array("Oval 1")).Top = tate後
Case 2
.Shapes.Range(Array("Oval 1")).Left = yoko訂
.Shapes.Range(Array("Oval 1")).Top = tate訂
Case 3
.Shapes.Range(Array("Oval 1")).Left = yoko修
.Shapes.Range(Array("Oval 1")).Top = tate修
End Select
.Range(adrs印刷帳票_台帳ER区分).Value = ws電消入力.Range(Cletterデータベース_台帳ER区分 & R).Value
.Range(adrs印刷帳票_台帳下4桁).Value = ws電消入力.Range(Cletterデータベース_台帳下4桁 & R).Value
.Range(adrs印刷帳票_連絡日).Value = ws電消入力.Range(Cletterデータベース_連絡日 & R).Value
.Range(adrs印刷帳票_集計年).Value = ws電消入力.Range(Cletterデータベース_集計年 & R).Value
.Range(adrs印刷帳票_集計月).Value = ws電消入力.Range(Cletterデータベース_集計月 & R).Value
.Range(adrs印刷帳票_台帳下4桁).Value = ws電消入力.Range(Cletterデータベース_バッチ下4桁 & R).Value
.Range(adrs印刷帳票_件数).Value = ws電消入力.Range(Cletterデータベース_件数 & R).Value
.Range(adrs印刷帳票_整理年月日).Value = ws電消入力.Range(Cletterデータベース_連絡日 & R).Value
.Range(adrs印刷帳票_年分).Value = ws電消入力.Range(Cletterデータベース_年分 & R).Value
.Range(adrs印刷帳票_連絡件数).Value = ws電消入力.Range(Cletterデータベース_件数 & R).Value
.Range(adrs印刷帳票_引受日).Value = ws電消入力.Range(Cletterデータベース_連絡日 & R).Value
.Range(adrs印刷帳票_誤り有無).Value = ws電消入力.Range(Cletterデータベース_誤り有無 & R).Value
.Range(adrs印刷帳票_回付日).Value = ws電消入力.Range(Cletterデータベース_回付日 & R).Value
'印刷(テストして問題なければprintpreviewをprintoutに書き換えて使用する）
.PrintPreview
'印刷対象列の値を「〇」から印刷済に変更
ws電消入力.Range(Cletterデータベース_印刷対象 & R).Value = "印刷済"
End With
'Forループを１回スキップしたいときはここに飛んでくる
continueNextFor:
Next R
MsgBox "印刷要求完了"
Application.EnableEvents = True
End Sub
'■■■■■DB初期化ボタン■■■■■
'注意：ボタン登録時別シートモジュールのマクロは見えないのでシート名とモジュール名を手打ちして登録する。
Sub btn電消入力シートのDB部分クリア()
'イベント二重起動防止
Application.EnableEvents = False
'データベース初期化
Dim ws電消入力 As Worksheet: Set ws電消入力 = ThisWorkbook.Worksheets("電消入力")
ws電消入力.Range(adrsデータベース_基点).CurrentRegion.Offset(1, 1).ClearContents
Application.EnableEvents = True
End Sub
4
(作成中）Windows標標準環境でFnキーをショートカットキーに割当て
（作成中）
1 目的
Windows標準環境下で、Microsoft edgeのFnキー押下をマウスジェスチャーに割り当てたかった。しかし、新たなソフトもインストールできないユーザー端末ではマウスジェスチャーは厳しそうなので、Fnキー押下の効果のバッチファイル を作り、ショートカットキー を割り当てることにする。
2
バッチファイル 内記述
@echo off
powershell -ExecutionPolicy Bypass -Command "Add-Type -AssemblyName System.Windows.Forms; [System.Windows.Forms.SendKeys]::SendWait('{F3}')"
exit/b
しかし、これではバッチファイル を実行しているコマンド画面にF3キーを送信してしまう。そこで、失敗を重ねつつ、バッチファイル をバックグラウンドで実行するか最小化して実行すればアクティブウインドウを奪わないことを思いついた。改行箇所に<br>、半角スペースにsquare capで表記すると以下。
@echo off<br>
rem␣バッチファイルが（最小化して）再起動していれば引数1を受け取っているはず。引数1を持っていないなら（最小化して再起動されていないなら）<br>
if␣not␣"%1"␣==␣"1"␣(<br>
rem␣自分自身を最小化して再起動する<br> start␣""␣/min␣cmd␣/c␣call␣"%~f0"␣1<br>
exit<br>
)<br>
rem␣バッチファイルは最小化されアクティブウインドウはバッチファイル 実行直前のウインドウに戻っているはずなのでFn3キーを送信する<br>
powershell␣-ExecutionPolicy␣Bypass␣-Command␣"[System.Windows.Forms.SendKeys]::SendWait('{F1}')"<br>
exit
最小化してもダメだったら。
# PowerShellのコード
# WindowsAPIの関数を定義する
Add-Type -MemberDefinition @'
[DllImport("user32.dll")]
public static extern IntPtr GetForegroundWindow();
[DllImport("user32.dll")]
public static extern IntPtr GetNextWindow(IntPtr hWnd, uint wCmd);
[DllImport("user32.dll")]
[return: MarshalAs(UnmanagedType.Bool)]
public static extern bool SetForegroundWindow(IntPtr hWnd);
'@ -Name User32 -Namespace Win32;
# 最前面のウインドウのハンドルを取得する
$hWnd = [Win32.User32]::GetForegroundWindow();
# Zオーダーでひとつ後ろのウインドウのハンドルを取得する
$nextHWnd = [Win32.User32]::GetNextWindow($hWnd, 2);
# 後ろのウインドウをアクティブにする
[Win32.User32]::SetForegroundWindow($nextHWnd);
#□PowerShellのコード<br>
<br>
#□WindowsAPIの関数を定義する<br>
Add-Type□-MemberDefinition□@'<br>
[DllImport("user32.dll")]<br>
public□static□extern□IntPtr□GetForegroundWindow();<br>
[DllImport("user32.dll")]<br>
public□static□extern□IntPtr□GetNextWindow(IntPtr□hWnd,□uint□wCmd);<br>
[DllImport("user32.dll")]<br>
[return:□MarshalAs(UnmanagedType.Bool)]<br>
public□static□extern□bool□SetForegroundWindow(IntPtr□hWnd);<br>
'@□-Name□User32□-Namespace□Win32;<br>
<br>
#□最前面のウインドウのハンドルを取得する<br>
$hWnd□=□[Win32.User32]::GetForegroundWindow();<br>
<br>
#□Zオーダーでひとつ後ろのウインドウのハンドルを取得する<br>
$nextHWnd□=□[Win32.User32]::GetNextWindow($hWnd,□2);<br>
<br>
#□後ろのウインドウをアクティブにする<br>
[Win32.User32]::SetForegroundWindow($nextHWnd);
3
自分が詰まったところを手当てしてる先人がいた。
「実用するには、キー入力が望むウィンドウに送られることが大事です。」
Windows10標準環境（デフォルト環境）のみでマクロのロック解除
(動作せず。ダメ）
0 準備
たとえば、対象として「locked.xlsm」ファイルを解除したいなら、名前の変更で「locked.xlsm.zip」に変更し、ダブルクリックで解凍し、xlフォルダ内のvbaProject.binファイルに対して変更処理を行うためのコードをchatGpt4に教えてもらう。
1 Bing(ChatGpt4)への質問
Vbscriptでバイナリファイル内の文字列DPBを文字列APBに変更して上書き保存するコードは？文字列の長さは同じことが前提で良いからコードは短い記載でお願い。変数名は長くても良いから分かりやすく命名して。コード内のコメントは各行について、小学生でも分かるくらい優しくお願い。起動の前提があれば詳細に説明して。
2回答
こんにちは、これはBingです。Vbscriptでバイナリファイル内の文字列DPBを文字列APBに変更して上書き保存するコードについてお答えします。
まず、バイナリファイルを読み書きするには、ADODB.Stream1というオブジェクトを使います。このオブジェクトは、バイナリデータをBytesという型のオブジェクトで扱います。しかし、この型はVBScriptにとって標準的な型ではなく、生成や編集ができない、配列っぽくて配列ではない扱いにくいものです。
そこで、MSXML2.DOMDocument2というオブジェクトを使って、Bytesと16進数文字列の相互変換を行います。このオブジェクトは、XMLを扱うものですが、DataTypeをbin.hexとすると、バイナリデータと16進数文字列の変換ができます。16進数文字列は単なる文字列なので、Replace3という関数で文字列の置換ができます。
以下のコードは、vbaProject.binというファイルを読み込んで、16進数文字列に変換し、DPBという文字列をAPBに置換して、同じファイルに上書き保存するものです。コード内のコメントは各行の処理を説明しています。
3コード
' バイナリファイルを読み込む関数
Function ReadBinaryFile(FileName)
' ADODB.Streamオブジェクトを作る
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
' バイナリモードにする
Stream.Type = 1
' ファイルを開く
Stream.Open
' ファイルを読み込む
Stream.LoadFromFile FileName
' バイト配列としてデータを取得する
ReadBinaryFile = Stream.Read
' ファイルを閉じる
Stream.Close
' オブジェクトを破棄する
Set Stream = Nothing
End Function
' バイナリファイルを書き込む関数
Function WriteBinaryFile(FileName, Data)
' ADODB.Streamオブジェクトを作る
Dim Stream
Set Stream = CreateObject("ADODB.Stream")
' バイナリモードにする
Stream.Type = 1
' ファイルを開く
Stream.Open
' バイト配列としてデータを書き込む
Stream.Write Data
' ファイルに保存する
Stream.SaveToFile FileName, 2
' ファイルを閉じる
Stream.Close
' オブジェクトを破棄する
Set Stream = Nothing
End Function
' バイト配列を16進数文字列に変換する関数
Function ConvertBytesToHexString(Data)
' MSXML2.DOMDocumentオブジェクトを作る
Dim Dom
Set Dom = CreateObject("MSXML2.DOMDocument").createElement("temp")
' DataTypeをbin.hexにする
Dom.DataType = "bin.hex"
' バイト配列をNodeTypedValueに代入する
Dom.NodeTypedValue = Data
' Textを16進数文字列として取得する
ConvertBytesToHexString = Dom.Text
' オブジェクトを破棄する
Set Dom = Nothing
End Function
' 16進数文字列をバイト配列に変換する関数
Function ConvertHexStringToBytes(Data)
' MSXML2.DOMDocumentオブジェクトを作る
Dim Dom
Set Dom = CreateObject("MSXML2.DOMDocument").createElement("temp")
' DataTypeをbin.hexにする
Dom.DataType = "bin.hex"
' 16進数文字列をTextに代入する
Dom.Text = Data
' NodeTypedValueをバイト配列として取得する
ConvertHexStringToBytes = Dom.NodeTypedValue
' オブジェクトを破棄する
Set Dom = Nothing
End Function
' ファイル名を指定する
Dim FileName
FileName = "vbaProject.bin"
' ファイルを読み込んでバイト配列にする
Dim Bytes
Bytes = ReadBinaryFile(FileName)
' バイト配列を16進数文字列に変換する
Dim HexString
HexString = ConvertBytesToHexString(Bytes)
' 16進数文字列のDPBをAPBに置換する
HexString = Replace(HexString, "445042", "415042")
' 16進数文字列をバイト配列に変換する
Bytes = ConvertHexStringToBytes(HexString)
' ファイルに書き込む
WriteBinaryFile(FileName, Bytes)
4 注意
このコードは、文字列の長さが同じであることが前提です。もし文字列の長さが異なる場合は、16進数文字列の長さやファイルのサイズも変わるので、それに合わせて調整する必要があります。
また、このコードは、vbaProject.binというファイルが存在することと、そのファイルがCompound File Binary Formatというファイル形式であることが前提です。もし別のファイルやファイル形式を扱う場合は、それに合わせて調整する必要があります。
このコードは、Vbscriptの標準機能とADODB.Stream1とMSXML2.DOMDocument2というオブジェクトを使っています。これらのオブジェクトは、Windowsの標準コンポーネントとしてインストールされていると思いますが、もしインストールされていない場合は、別途インストールする必要があります。
以上が、Vbscriptでバイナリファイル内の文字列DPBを文字列APBに変更して上書き保存するコードの説明です。ご参考になれば幸いです。😊
5 感想 vbaProject.binのフルパスに書き換える必要がある。
マジックナンバーを排除した転記 part1
１ 転記項目が多いときにセル番号を直打ちしていると、後から修正訂正が発生したとに大変なことになる。そこで、セル番地を定数として登録してから行動する。
２ シートのイベントを使う場合、シートモジュールを使う。標準モジュールとシートモジュールを同時に使うときに定数を共有しようとすると標準モジュールにPublic Const として大量に羅列することになりプロジェクト直下で管理する定数が増えてしまう。そこで、基本的にすべてシートモジュールに押し込み、シートモジュールのConstとして処理した。
しかし、以下の大量のConstを見ると嫌な気持ちになるのでこれをどうにか修正していきたい。
３ コード
シート構成は、
入力シート１枚（左端縦方向に入力欄、その右側にデータベース部分）
出力シート2枚（電所シート（通常給紙のプリンタ設定）と電所手差しシート（プリンタを手差し設定済のもの））。帳票様式は全く一緒だが、Excelはシート毎にプリンタ設定を保存しているため、事前に手動で給紙方法を違う設定でシートを保存しておくことでプリンタや給紙方法を切り替えることを実現できる。以下では、通常給紙（白紙）と手差し給紙（色紙）を切り替えている。
シートモジュール（電所入力シート）
Option Explicit
'イベントの途中でエラーになったりステップ実行途中で抜けると、イベント発生不可のままになってしまうので、
'イベントが発生しなくなってしまったらイミディエイトウインドウで Application.EnableEvents = True とする。
'ここは電所入力シートモジュール
'電所入力シート
'入力項目のセルアドレス
Const adrs入力_集計年月 = "B2"
Const adrs入力_入力ID_呼出用 = "B３"
Const adrs入力_年分 = "C4"
Const adrs入力_台帳ER区分 = "C５"
Const adrs入力_台帳下4桁 = "C6"
Const adrs入力_バッチ下4桁 = "C7"
Const adrs入力_有還無区分 = "C8"
Const adrs入力_SKoku区分 = "C9"
Const adrs入力_件数 = "C10"
Const adrs入力_誤り有無 = "C11"
Const adrs入力_連絡日 = "C12"
Const adrs入力_回付日 = "C13"
Const adrs入力_転記実行セルの1つ下 = "C16"
Const adrs入力_文字色変更対象範囲 = "C４：C13"
'電所入力シート
'データベース部分(一旦の転記してデータを溜めておく部分)
'列記号(columnLetter）ex.F10セルの「F」のこと。
Const Cletter転記先_入力ID = "F"
Const CLetter転記先_連番 = "F"
Const CLetter転記先_印刷対象 = "G"
Const CLetter転記先_集計年月 = "H"
Const CLetter転記先_年分 = "I"
Const CLetter転記先_台帳ER区分 = "J"
Const CLetter転記先_台帳下4桁 = "K"
Const CLetter転記先_バッチ下4桁 = "L"
Const CLetter転記先_有還無区分 = "M"
Const CLetter転記先_SKoku区分 = "N"
Const CLetter転記先_件数 = "O"
Const CLetter転記先_誤り有無 = "P"
Const CLetter転記先_連絡日 = "Q"
Const CLetter転記先_回付日 = "R"
'セル番地
Const adrs転記先_データベース_基点 = "Ｆ９"
'行番号
Const RNoデータベース_タイトル行番号 = 9
Const RNoデータベース_開始行番号 = 10
'出力帳票(電所シート）
'転記先セルアドレス
Const adrs出力_年分 = "R1"
Const adrs出力_台帳ER区分 = "R2"
Const adrs出力_台帳下4桁 = "R3"
Const adrs出力_集計年 = "D14" '集計年だけ直接出力シートの該当箇所に転記
Const adrs出力_集計月 = "R4"
Const adrs出力_バッチ下4桁 = "R5"
Const adrs出力_有還無区分 = "R6"
Const adrs出力_SKoku区分 = "R7"
Const adrs出力_件数 = "R8"
Const adrs出力_誤り有無 = "R9"
Const adrs出力_連絡日 = "R10"
Const adrs出力_回付日 = "R11"
'■■■■■一括印刷ボタン■■■■■
Sub btn電子データ整理表へ転記しながら一括印刷()
Application.EnableEvents = False
'シート設定
Dim ws電所入力 As Worksheet: Set ws電所入力 = ThisWorkbook.Worksheets("電所入力")
Dim ws電所 As Worksheet: Set ws電所 = ThisWorkbook.Worksheets("電所")
Dim ws電所手差し As Worksheet: Set ws電所手差し = ThisWorkbook.Worksheets("電所手差し")
'目的：手差し用紙をセットしたか確認メッセージを表示する
'表示メッセージ内容
Dim m As String: m = ""
m = m & "マイナス(有還無区分２）は手差し給紙です。" & vbNewLine
m = m & "手差し用紙をセットしましたか？" & vbNewLine
m = m & "「印刷対象」列に〇が入っている行を印刷します。" & vbNewLine
m = m & "印刷実行しますか？" & vbNewLine
'手差し用紙をセットしていなかったら印刷をキャンセル。ボタン選択のデフォルト位置はキャンセル
If MsgBox(m, vbOKCancel + vbDefaultButton2) = vbCancel Then
MsgBox "印刷をキャンセルします"
Exit Sub
End If
'目的：転記（DB→出力用帳票へ）して印刷をループ
Dim R As Long
For R = RNoデータベース_開始行番号 To ws電所入力.Range(CLetter転記先_印刷対象 & ws電所.Rows.Count).End(xlUp).Row
'印刷対象列に〇がないときは転記と印刷をスキップする
If ws電所入力.Range(CLetter転記先_印刷対象 & R).Value <> "〇" Then GoTo continueNextFor
'Ifの中で印刷までやるとコードが長くなって嫌なので、無駄があるが両方のシートに転記しちゃってから印刷だけIfで分けた。
'出力シート_電所（通常印刷設定）へ転記
With ws電所
'転記先は集計年、転記元は集計年月なので上二桁で集計年にする
.Range(adrs出力_集計年).Value = Left(ws電所入力.Range(CLetter転記先_年分 & R).Value, 2)
'転記先は集計月、転記元は集計年月なので下二桁で集計年にする
.Range(adrs出力_集計月).Value = Right(ws電所入力.Range(CLetter転記先_年分 & R).Value, 2)
.Range(adrs出力_年分).Value = ws電所入力.Range(CLetter転記先_年分 & R).Value
.Range(adrs出力_台帳ER区分).Value = ws電所入力.Range(CLetter転記先_台帳ER区分 & R).Value
.Range(adrs出力_台帳下4桁).Value = ws電所入力.Range(CLetter転記先_台帳下4桁 & R).Value
.Range(adrs入力_バッチ下4桁).Value = ws電所入力.Range(CLetter転記先_バッチ下4桁 & R).Value
.Range(adrs出力_有還無区分).Value = ws電所入力.Range(CLetter転記先_有還無区分 & R).Value
'電所シートの丸囲みを動かすイベント実行。書き直す時間がないので過去のシートイベントを流用するため一時的にイベントをONにする。
Application.EnableEvents = True
.Range(adrs出力_SKoku区分).Value = ws電所入力.Range(CLetter転記先_SKoku区分 & R).Value
Application.EnableEvents = False
.Range(adrs入力_件数).Value = ws電所入力.Range(CLetter転記先_件数 & R).Value
.Range(adrs入力_誤り有無).Value = ws電所入力.Range(CLetter転記先_誤り有無 & R).Value
.Range(adrs出力_連絡日).Value = ws電所入力.Range(CLetter転記先_連絡日 & R).Value
.Range(adrs出力_回付日).Value = ws電所入力.Range(CLetter転記先_回付日 & R).Value
End With
'出力シート_電所（手差し印刷設定）へ転記
With ws電所手差し
'転記先は集計年、転記元は集計年月なので上二桁で集計年にする
.Range(adrs出力_集計年).Value = Left(ws電所入力.Range(CLetter転記先_年分 & R).Value, 2)
'転記先は集計月、転記元は集計年月なので下二桁で集計年にする
.Range(adrs出力_集計月).Value = Right(ws電所入力.Range(CLetter転記先_年分 & R).Value, 2)
.Range(adrs出力_年分).Value = ws電所入力.Range(CLetter転記先_年分 & R).Value
.Range(adrs出力_台帳ER区分).Value = ws電所入力.Range(CLetter転記先_台帳ER区分 & R).Value
.Range(adrs出力_台帳下4桁).Value = ws電所入力.Range(CLetter転記先_台帳下4桁 & R).Value
.Range(adrs入力_バッチ下4桁).Value = ws電所入力.Range(CLetter転記先_バッチ下4桁 & R).Value
.Range(adrs出力_有還無区分).Value = ws電所入力.Range(CLetter転記先_有還無区分 & R).Value
'電所シートの丸囲みを動かすイベント実行。書き直す時間がないので過去のシートイベントを流用するため一時的にイベントをONにする。
Application.EnableEvents = True
.Range(adrs出力_SKoku区分).Value = ws電所入力.Range(CLetter転記先_SKoku区分 & R).Value
Application.EnableEvents = False
.Range(adrs入力_件数).Value = ws電所入力.Range(CLetter転記先_件数 & R).Value
.Range(adrs入力_誤り有無).Value = ws電所入力.Range(CLetter転記先_誤り有無 & R).Value
.Range(adrs出力_連絡日).Value = ws電所入力.Range(CLetter転記先_連絡日 & R).Value
.Range(adrs出力_回付日).Value = ws電所入力.Range(CLetter転記先_回付日 & R).Value
End With
'目的：場合分けして別シートを印刷
'還なら手差し印刷
If ws電所入力.Range(CLetter転記先_有還無区分 & R).Value = 2 Then
' PrintPreviewをPintoutにすれば印刷される
ws電所手差し.PrintPreview
'還以外なら通常印刷
Else
' PrintPreviewをPintoutにすれば印刷される
ws電所.PrintPreview
End If
'印刷対象列の値を「〇」から印刷済に変更
ws電所入力.Range(CLetter転記先_印刷対象 & R).Value = "印刷済"
'Forループを１回スキップしたいときはここに飛んでくる
continueNextFor:
Next R
MsgBox "印刷要求完了"
Application.EnableEvents = True
End Sub
'■■■■■DB初期化ボタン■■■■■
'注意：ボタン登録時別シートモジュールのマクロは見えないのでシート名とモジュール名を手打ちして登録する。
Sub btn電所入力シートのDB部分クリ()
'イベント停止。changeイベントの中のtarget.valueが単一セルではなくセル「範囲」を変更するとエラーになるから。
Application.EnableEvents = False
'DB（データベース）部分初期化
Dim ws電所入力 As Worksheet: Set ws電所入力 = ThisWorkbook.Worksheets("電所入力")
ws電所入力.Range(adrs転記先_データベース_基点).CurrentRegion.Offset(1, 1).ClearContents
'目的:入力ID呼出用を入力した状態でDB部分クリアした場合に入力欄を初期化する
'入力用セルの文字色を黒に戻す
ws電所入力.Range(adrs入力_文字色変更対象範囲).Font.Color = vbBack
'入力ID呼出用セルを初期化
ws電所入力.Range(adrs入力_入力ID_呼出用).Value = ""
Application.EnableEvents = True
End Sub
'■■■■■ダブルクリックイベント■■■■■
'ダブルクリックしたセルが特定の範囲にあった場合
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'ダブルクリックしたセルの列記号で場合分け
Select Case Split(Target.Address, "$")(1)
'ダブルクリックしたセルがG列だったら
Case "G"
'ダブルクリックしても編集モードにしない
Cancel = True
' ダブルクリックしたセルの値で場合分け
Select Case Target.Value
' セルの値が空欄だったら”〇”を入力
Case ""
Target.Value = "〇"
' セルの値が”〇”だったら空欄にする
Case "〇", "印刷済"
Target.Value = ""
End Select
End Select
End Sub
'■■■■■チェンジイベント■■■■■
'「入力ID呼出用」セルに数字を入力した場合
Private Sub Worksheet_Change(ByVal Target As Range)
'イベント二重起動防止
Application.EnableEvents = False
' 複数セル一括変更した場合は実行しない｡単一セルのみ｡複数セル選択時にtarget.valueがエラーとなる対策。
If Target.Count > 1 Then Exit Sub
'シート設定
Dim ws入力 As Worksheet: Set ws入力 = Me
Dim RNoデータベース_取得行番号: RNoデータベース_取得行番号 = ws入力.Range(adrs入力_入力ID_呼出用).Value + RNoデータベース_タイトル行番号
'目的：入力欄の入力ID呼出用セルに数字を入れたらDBからデータを呼び戻して訂正して転記できるようにする。
'入力ID_呼出用の値が変更された場合
With ws入力
Select Case True
'訂正のために入力ID_呼出用に数字を入れたとき（複数セル同時に変更するとtarget.valueが型エラーになってしまうのでプロシージャ冒頭で事前にExit Subで対策してある）
Case Target.Address(0, 0) = adrs入力_入力ID_呼出用 And Target.Value <> ""
'入力ID_呼出用に該当するデータをDB範囲から呼び戻す
'例）入力欄の年分セルに、データベース部分の入力IDに該当するデータを､代入する
.Range(adrs入力_集計年月).Value = .Range(CLetter転記先_集計年月 & RNoデータベース_取得行番号).Value
.Range(adrs入力_年分).Value = .Range(CLetter転記先_年分 & RNoデータベース_取得行番号).Value
.Range(adrs入力_台帳ER区分) = .Range(CLetter転記先_台帳ER区分 & RNoデータベース_取得行番号).Value
.Range(adrs入力_台帳下4桁) = .Range(CLetter転記先_台帳下4桁 & RNoデータベース_取得行番号).Value
.Range(adrs入力_バッチ下4桁) = .Range(CLetter転記先_バッチ下4桁 & RNoデータベース_取得行番号).Value
.Range(adrs入力_有還無区分) = .Range(CLetter転記先_有還無区分 & RNoデータベース_取得行番号).Value
.Range(adrs入力_SKoku区分) = .Range(CLetter転記先_SKoku区分 & RNoデータベース_取得行番号).Value
.Range(adrs入力_件数) = .Range(CLetter転記先_件数 & RNoデータベース_取得行番号).Value
.Range(adrs入力_誤り有無) = .Range(CLetter転記先_誤り有無 & RNoデータベース_取得行番号).Value
.Range(adrs入力_連絡日) = .Range(CLetter転記先_連絡日 & RNoデータベース_取得行番号).Value
.Range(adrs入力_回付日) = .Range(CLetter転記先_回付日 & RNoデータベース_取得行番号).Value
'訂正入力中であることを表示するため、一部文字色を赤に
.Range(adrs入力_文字色変更対象範囲).Font.Color = vbRed
'次の入力欄へアクティブセルを動かす
.Range(adrs入力_年分).Select
'訂正をやめるために入力ID_呼出用の数字を削除したとき（手動削除又は訂正入力内容を転記するイベント発生により入力ID_呼出用が削除したとき）
Case Target.Address(0, 0) = adrs入力_入力ID_呼出用 And Target.Value = ""
'訂正入力しないということなので、文字色を黒に戻す
.Range(adrs入力_文字色変更対象範囲).Font.Color = vbBlack
'次の入力欄へアクティブセルを動かす
.Range(adrs入力_年分).Select
End Select
End With
Application.EnableEvents = True
End Sub
'■■■■■セレクションチェンジイベント■■■■■
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'イベント二重起動防止
Application.EnableEvents = False
'シート設定
Dim ws入力 As Worksheet: Set ws入力 = Me
'目的：BackTabボタン、Tabボタンで移動できるようにアクティブセルを制御
'ここはセル番地を直打ちした方が分かり易いと思う
Select Case Target.Address(0, 0)
'BackTab用
Case "B5"
Range("C4").Select
Case "B6"
Range("C5").Select
Case "B7"
Range("C6").Select
Case "B8"
Range("C7").Select
Case "B9"
Range("C8").Select
Case "B10"
Range("C9").Select
Case "B11"
Range("C10").Select
Case "B12"
Range("C11").Select
Case "B13"
Range("C12").Select
Case "B14"
Range("C13").Select
Case "B15"
Range("C14").Select
'Tab用
Case "D４"
Range("C5").Select
Case "D5"
Range("C6").Select
Case "D6"
Range("C7").Select
Case "D7"
Range("C8").Select
Case "D8"
Range("C9").Select
Case "D9"
Range("C10").Select
Case "D10"
Range("C11").Select
Case "D11"
Range("C12").Select
Case "D12"
Range("C13").Select
Case "D13"
Range("C14").Select
Case "D14"
Range("C15").Select
End Select
'転記
'目的：「転記実行」と書いてあるセルでEnterキーを押した場合、①単純転記し、さらに②入力ID呼出用の値が入っていいる場合には微調整をする。
If Target.Address(0, 0) = adrs入力_転記実行セルの1つ下 Then
'①入力欄からDB範囲へ転記する
With ws入力
'注）ループ内で変数宣言しても宣言処理は1回しか実行されないので問題なし
Dim RNo転記先 As Long: RNo転記先 = .Range(CLetter転記先_年分 & .Rows.Count).End(xlUp).Row + 1
'転記作業
'注）漢数字の〇と記号の〇は違うので全プロシージャで統一しておかないと正しく動作しない
.Range(CLetter転記先_印刷対象 & RNo転記先).Value = "〇"
.Range(CLetter転記先_集計年月 & RNo転記先).Value = .Range(adrs入力_集計年月)
.Range(CLetter転記先_年分 & RNo転記先).Value = .Range(adrs入力_年分)
.Range(CLetter転記先_台帳ER区分 & RNo転記先).Value = .Range(adrs入力_台帳ER区分)
.Range(CLetter転記先_台帳下4桁 & RNo転記先).Value = .Range(adrs入力_台帳下4桁)
.Range(CLetter転記先_バッチ下4桁 & RNo転記先).Value = .Range(adrs入力_バッチ下4桁)
.Range(CLetter転記先_有還無区分 & RNo転記先).Value = .Range(adrs入力_有還無区分)
.Range(CLetter転記先_SKoku区分 & RNo転記先).Value = .Range(adrs入力_SKoku区分)
.Range(CLetter転記先_件数 & RNo転記先).Value = .Range(adrs入力_件数)
.Range(CLetter転記先_誤り有無 & RNo転記先).Value = .Range(adrs入力_誤り有無)
.Range(CLetter転記先_連絡日 & RNo転記先).Value = .Range(adrs入力_連絡日)
.Range(CLetter転記先_回付日 & RNo転記先).Value = .Range(adrs入力_回付日)
End With
'② 転記時に入力ID呼出用が書いてあったら（新しい入力IDとして転記済なので）古い入力IDの行について印刷対象から除外。入力ID呼出用セルは初期化する。
With ws入力
If .Range(adrs入力_入力ID_呼出用).Value <> "" Then
Dim m As String
m = ""
m = "入力ID" & .Range(adrs入力_入力ID_呼出用).Value & "を印刷対象から除外します。"
MsgBox m
'目的：呼出後転記済の「入力ID」行の「印刷対象」列の〇を削除し､呼び出したときに使用した入力欄の「入力ID呼出用」セルのデータを削除して初期化
'データベース部分から取得する行
Dim RNoデータベース_取得行: RNoデータベース_取得行 = RNoデータベース_タイトル行番号 + ws入力.Range(adrs入力_入力ID_呼出用).Value
'印刷対象欄の〇を削除
.Range(CLetter転記先_印刷対象 & RNoデータベース_取得行).Value = ""
'呼び出しに使った入力ID呼出用セルの値を削除
.Range(adrs入力_入力ID_呼出用).Value = ""
'訂正入力終了したので、文字色を黒に戻す（一手前でセルの値削除時にenableEbentして値削除イベントにより文字を黒くするより、ここで単純に文字を黒に戻した）
.Range(adrs入力_文字色変更対象範囲).Font.Color = vbBlack
End If
End With
'入力欄の先頭セルをアクティブにする
Range(adrs入力_年分).Select
End If
'イベント起動可に戻す
Application.EnableEvents = True
End Sub
Option Explicit
'ここは電所シートモジュール（出力帳票１）
'■■■■ワークシートチェンジイベントでオートシェイプの丸囲みを移動する
'最初にこれだけ作ったのでこれを生かして暫定運用
Private Sub Worksheet_Change(ByVal Target As Range)
Const adrsMySK区分 = "R7"
'整理表のSK区分のx座標とｙ座標一覧
Const yoko内 = 270: Const yoko分 = 355: Const yoko訂正 = 473
Const tate内 = 190: Const tate分 = 290: Const tate訂正 = 190
Const yoko後 = 270: Const yoko損 = 355: Const yoko修 = 473
Const tate後 = 250: Const tate損 = 250: Const tate修 = 250
If Not (Intersect(Target, Me.Range(adrsMySK区分)) Is Nothing) Then
' sk区分を番号で入力セルから取得
Dim mySK区分 As Long: mySK区分 = Me.Range(adrsMySK区分).Value
Dim x As Long, y As Long
Select Case mySK区分
Case 1
x = yoko内
y = tate内
Case 2
x = yoko分
y = tate分
Case 3
x = yoko訂正
y = tate訂正
Case 4
x = yoko後
y = tate後
Case 5
x = yoko損
y = tate損
Case 6
x = yoko修
y = tate修
End Select
'〇囲みを移動
'注）オートシェイプの〇囲みを削除してしまったら、図形の名前を書き換える必要がある
Me.Shapes.Range("Oval 1").Left = x
Me.Shapes.Range("Oval 1").Top = y
End If
End Sub
Option Explicit
'ここは電所手差しシートモジュール（出力帳票２）
'■■■■ワークシートチェンジイベントでオートシェイプの丸囲みを移動する
'最初にこれだけ作ったのでこれを生かして暫定運用
Private Sub Worksheet_Change(ByVal Target As Range)
Const adrsMySK区分 = "R7"
'整理表のSK区分のx座標とｙ座標一覧
Const yoko内 = 270: Const yoko分 = 355: Const yoko訂正 = 473
Const tate内 = 190: Const tate分 = 290: Const tate訂正 = 190
Const yoko後 = 270: Const yoko損 = 355: Const yoko修 = 473
Const tate後 = 250: Const tate損 = 250: Const tate修 = 250
If Not (Intersect(Target, Me.Range(adrsMySK区分)) Is Nothing) Then
' sk区分を番号で入力セルから取得
Dim mySK区分 As Long: mySK区分 = Me.Range(adrsMySK区分).Value
Dim x As Long, y As Long
Select Case mySK区分
Case 1
x = yoko内
y = tate内
Case 2
x = yoko分
y = tate分
Case 3
x = yoko訂正
y = tate訂正
Case 4
x = yoko後
y = tate後
Case 5
x = yoko損
y = tate損
Case 6
x = yoko修
y = tate修
End Select
'〇囲みを移動
'注）オートシェイプの〇囲みを削除してしまったら、図形の名前を書き換える必要がある
Me.Shapes.Range("Oval 1").Left = x
Me.Shapes.Range("Oval 1").Top = y
End If
End Sub
４ 参考
『マジックナンバーを減らそうとすると、書き始めは大変かもしれません。
しかし、定数定義さえ終わってしまえば、あとはスムーズにコードが書けます。
さらには改修が発生したときや、あとで発見されたバグを修正するときには、
定数だけいじればよいというメンテナンス性で、すさまじい効果を実感できます。
マジックナンバーを減らすことは「未来への贈り物」です。
贈る相手が自分にせよ他人にせよ、未来の誰かが苦労しないために、
マジックナンバーをがんばって減らしていきましょう。』
（編集中）onkeyを使わないでEnterキーでマクロ実行
1 シートモジュールのselectionchangeのtargetを実行トリガーとしたいセルの1つ下のセルにする。Enerを押す前のセルを掴むのは工夫が必要なので、Enterを押した後のセルをトリガーにする。
2シートモジュールのchangeのtargetに何らかの値（「1」など）を入れてEnterすることでセルをchangeしてトリガーにする。
excelVBA本格入門を読みながら当時考えたこと
Option Explicit
'図形をShift+ドラッグは比率維持,Alt+ドラッグはぴったり移動、Ctr＋ドラッグはコピー
'Ctr＋クリックで、マクロを実行することなくボタンを選択できる。
'マクロをショートカットキーに登録することもできる。クイックアクセスツールバーにも。
'キーワードを選択しておいて、F1でヘルプを開く。
'モジュールとは。マクロを記述するための専用シート
'プロジェクトとは。モジュールの集まり。
'プロジェクト＝標準モジュール+ユーザーフォーム＋クラスモジュール＋Excelオブジェクト（ブック、ワークシート、グラフシート)
'Excelブック＝ワークシート＋グラフシート
'自動メンバー表示の後、Tabで確定。Enterは確定改行。
'バグを発見する方法は、疑わしい位置で実行を中断し、そこから動作確認しながら1ステップずつ実行していく。
'ステップインしたら、Excel上でその1つ前のステートメントが期待通り動作したか確認する。これを繰り返す。
'(田中亨メモ）
'１マクロ記録する
'２マクロ記録を読む
'3無駄を省く（シェイプ等はSlectとSelectionが違うので、削りすぎてエラーになったらSelectionは残せばよい
'４メソッドプロパティに検討がついたらヘルプを見る（F1）
'
'マクロ記録は必要なコードを作ってくれる機能ではない。
'マクロ記録は行った操作をVBAのコードとして記述するだけ。
'解説機能はヘルプF1
'マクロ記録だけでは対話型マクロと条件分岐や繰り返しが作れない。
'オブジェクトとは。excelの部品。例。ブック、シート、セル
'自動車（アプリケーション＝Excel）、ボディー、タイヤ、エンジン（オブジェクト＝Excelの部品）
'プロパティとは。オブジェクトの「特徴」のこと。
'オブジェクト式
'①対象.命令 ②対象.様子＝値 ③対象.様子
'変数とは。箱。
'階層構造を省略しなければ、アクティブではないシートに代入（計算）できる。
'選択（指定）さでできれば、代入（計算）できる。
'（ちゅんちゅんメモ）
'BookとSheet を省略しないで書く。省略を発見したらすぐ補完しておく。
'コレクションとは。オブジェクトの集合体。オブジェクトとは。部品。
'すべてのブックを閉じる
sub すべてのブックを閉じる()
Workbooks.Close
End sub
'VBAでは「Workbooks」のようなコレクションを特定するためのキーワードはプロパティに分類される。
'Workbooks(1).close
' (ワークブックスプロパティ）に（引数）を指定するとWorkbookオブジェクトが特定できる。
'セルというオブジェクトを特定するキーワードをCellsプロパティ、ActiveCellプロパティ、Offsetプロパティ、と表現する。
'事例１ 保存場所を特定してブックを開く
sub ブックを開く()
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:="C:\honkaku\Hoge.xlsx")
End sub
'カレントフォルダとは。現在選択されているフォルダ。[ファイルを開く]ダイアログボックスに表示されているフォルダ。
'事例２ カレントフォルダのブックを開く
sub ブックを開く2()
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:="Hoge.xlsx")
End sub
'カレントフォルダはどうやって変更するのか
'ユーザーの[ドキュメント]フォルダが既定のカレントフォルダ
'［名前をつけて保存］で保存先を変えるとCurDirも変わる。
'chDirステートメントで変更。curDir関数で確認。
'
'パスを指定してブックを開く（田中亨）
' Workbooks.Open ファイル名
' （ファイルのパス。＝パス￥ファイル名）
sub ブックのコピー()
''新規ブックできる
ThisWorkbook.Sheets.Copy
'保存する
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\HogeHoge.xlsx"
End sub
'事例３ ブックを保存して閉じる
sub ブックを保存して閉じる()
Workbooks("Hoge.xlsx").Close savechanges:=True
End sub
'事例４
sub 印刷プレビューを実行する()
ThisWorkbook.Worksheets("売上台帳").PrintPreview
End sub
sub 印刷実行()
ThisWorkbook.Worksheets("Hoge.xlsx").PrintOut
End sub
'事例5
sub シートの削除()
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Hoge").Delete
Application.DisplayAlerts = True
End sub
'
'
sub シートのコピー()
' Thisworkbook.Worksheets("Hoge").Copy Before:=
' After:=
'End sub
'
'
sub シートの追加()
' Worksheets("Hoge").Add
' Before:=
' After:=
' count:=
'End sub
sub シートを追加してすぐ名前を付ける()
ThisWorkbook.Worksheets.Add.Name = "Huga"
'worksheets.addで追加したワークシートオブジェクトが返る
End sub
sub シートの非表示_ユーザー再表示可()
ThisWorkbook.Worksheets("Hoge").Visible = xlSheetHidden
End sub
sub シートの非表示_ユーザー再表示不可能()
ThisWorkbook.Worksheets("Hoge").Visible = xlSheetVeryHidden
End sub
sub シートの再表示()
ThisWorkbook.Worksheets("Hoge").Visible = xlSheetVisible
End sub
'コレクションとは。オブジェクトの集合体。
'rangeコレクションは存在しない。１つのセルでもセル範囲でもRangeオブジェクト。注意。
'セルをコピーするには。
' コピー元のセル.Copy コピー先のセル
sub 非連続セル範囲の選択()
Range("A1,B2,C3,D4").Select
Range("A1:C3,E5:F8").Select
' セル範囲の選択は range("左上セル","右下セル")
Range(Cells(2, 2), Cells(5, 2)).Select
' →For Next構文の中で､
' Range(Cells(i,2), cells(i,5))とすれば条件に合致するデータを行単位で操作できる。
' →Range(cells(i,2), Cells(i,2).end(xltoRight)
End sub
sub 名前が定義されたセルを選択する11()
'セル範囲に売上合計という名前の定義がされていることを前提として
'名前の定義は 右クリックや名前ボックスで行う
Range("売上合計").Select
End sub
sub 行全体や列全体を取得する方法12()
'A列からD列及びF列を取得する
Range("A:D,F:F").Select
'1行目から4行目まで及び6行目を取得する
Range("1:4,6:6").Select
End sub
sub すべてのセルを選択する13()
Cells.Select
End sub
'SelectするにはRangeオブジェクトの親オブジェクト（シートオブジェクト）がアクティブになっている必要がある
sub アクティブシートになっていないRangeはセレクトできない13_2()
Workbooks("hoge.xlsx").Worksheets("Fuga").Range("A1:D30").Select
End sub
sub Rangeをselectするには2段階に分けて親シートをアクティブにしてから13_2()
Workbooks("hoge.xlsx").Worksheets("Fuga").Activate
Range("A1:D25").Select
End sub
sub アクティブシートになくてもセルを1発で選択する13_3()
Application.Goto Workbooks("hoge.xlsx").Worksheets("Fuga").Range("A1:D30")
End sub
'withブロックで、
'With Workbook("").Worksheets("")
'と1行にするか、
'With Workbook("")
' With Worksheets("")
'と入れ子にするかは､Withの中で複数シート触るなら分けた方が良い｡
sub Not演算子でプロパティのオンオフ切替14()
'Dr列を
With Columns("D")
'表示のオンオフ切替
.Hidden = Not .Hidden
End With
End sub
'田中亨メモ
'値の設定文やどこかに何かを代入する､というとき
'まず「何を」ではなく、「どこへ」という受け取り側をイメージする。
'VBAの構文①オブジェクト式②ステートメント③関数
'オブジェクト式の基本2文型①対象.命令､②対象.様子 = 値
'操作対象がセルのとき､.Valueは省略できる｡読みやすい方を使う｡読みやすいかどうかは自分が決めること｡
sub セルの数式と値をクリアする19_1()
Range("A1").Select
'activecellプロパティは１つのセル（アクティブセル）を特定し
ActiveCell.Value = ""
End sub
sub セルの内容をクリアする19_2()
Range("A1.D14").Select
'clearcontentsならセル範囲もクリアできる。
'Selectionはアクティブセルも選択セル範囲も特定できる。
'選択セルの数式と値をクリアする
Selection.Value.ClearContents
'選択セルの書式クリア
Selection.Value.ClearFormats
'選択セルのコメント削除
Selection.Value.CcearComments
'選択セルの数式、値、コメント、書式すべて削除
Selection.Value.ClearContents
End sub
sub 選択セル範囲の位置を変更する20()
Range("C2:D6").Select
Selection.Offset(-1, 2).Select
End sub
sub 選択セル範囲の行位置を変更する21()
Range("C2:D6").Select
'０を省略できるからといって省略したら読みにくい
Selection.Offset(-1, 0).Select
End sub
sub 選択セル範囲の列位置を変更する22()
Range("C2:D6").Select
'０を省略できるからといって省略したら読みにくい
Selection.Offset(0, 2).Select
End sub
sub VBAにはLookupがないのでデータベース上で特定のセルを発見してOffsetでズラす22_2()
'結果としてA1セルを選択している
Range("B2").Offset(-1, -1).Select
End sub
sub VBAにはLookupがないのでデータベースのセル範囲の中からCellsで選ぶ22_3()
'結果としてA1セルを選択している
Range("A1:C3").Cells(1, 1).Select
End sub
'行を特定するRowsプロパティは、行を表すRangeオブジェクトを返す
sub 行を非表示にする23()
Worksheets("Hoge").Rows("5:7").Hidden = True
End sub
sub Rowsプロパティは離れた行を選択できない23_2()
' 離れた行を掴もうとするとエラーになる
Rows("1:3,6:6").Select
'Rangeの方がスゴイ
Range("1:3,6:6").Select
End sub
sub 選択されているセル範囲の行数を数える24()
Range("B5:D8").Select
MsgBox Selection.Rows.Count
'Rowプロパティは選択されているセルの行番号(整数）を返すプロパティ。RowじゃなくてRowNumberだったら分かりやすかった。
MsgBox Range("C8").Row
'cf. rowsプロパティは行を表すRangeオブジェクトを返すプロパティ。全く違う。
End sub
sub 選択されているセル範囲の列数を数える25()
Range("B5:D8").Select
MsgBox Selection.Columns.Count
'columnプロパティは選択されているセルの列番号(整数）を返すプロパティ。columnじゃなくてcolumnNumberだったら分かりやすかった。
MsgBox Range("C8").Column
'cf. columnsプロパティは列を表すRangeオブジェクトを返すプロパティ。全く違う。
End sub
sub 行数や列数が取得できたらセル範囲のサイズを変更する26()
Range("B2:C4").Select
MsgBox "選択セル範囲のサイズを変更します"
'選択されているセル範囲の行数と列数を求めてから加減する
Selection.Resize(Selection.Rows.Count + 2, Selection.Columns.Count - 1).Select
'selection.rowsとselection.columnsはrangeオブジェクトを返している
'selectionを使わないで書くと
Range("B2").CurrentRegion.Resize(Range("B2").CurrentRegion.Rows.Count + 2, Range("B2").CurrentRegion.Columns.Count - 1).Select
End sub
sub 表全体の行数から見出しの1行分小さくリサイズして1段下げる26_2()
' resizeの引数の列数を省略すると変更前と同じになる
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1, 0).Select
End sub
'セルのデータ初期化に使いやすい
sub 表全体の行数から見出しの1行分小さくリサイズして1段下げる26_3()
With Range("A1").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 0).ClearContents
End With
End sub
sub offset関数のやっていること27()
Range("B2:C4").Select
MsgBox "選択セル範囲のサイズを変更します"
'resizeの引数の行数（列数）を省略すると、変更前と同じになる。
Selection.Offset(0, 2).Resize(, Selection.Columns.cout + 2).Select
End sub
'アクティブセル領域とは。空白の行と空白の列に囲まれたセル範囲のこと。
'アクティブセル領域は、currentRegionプロパティで特定できる。
sub アクティブセル領域を選択する28()
Range("B2").CurrentRegion.Select
End sub
sub データベース範囲を選択する29()
'1行目の見出し行のセルには文字（見出し）が入力されているので基点セルとする。
'2行目以降だと1件もデータがない可能性がある。基点セルは見出し行のセルでなければダメ。
'見出し行を基点にする
Range("A1").CurrentRegion.Select
End sub
sub データ弁ス範囲を印刷する30()
Range("A1").CurrentRegion.Name = "顧客"
'ここでは、印刷は念のためコメントアウトしておく
'ActiveSheet.PrintOut
'印刷プレビュー
ActiveSheet.PrintPreview
End sub
sub データの登録件数を取得31()
MsgBox Range("A1").CurrentRegion.Rows.Count - 1
End sub
sub データの新規入力行を取得31_2()
MsgBox Range("A1").CurrentRegion.Rows.Count + 1
End sub
'Excelの機能「Endモード」 ctrキーでEndモードになる。マクロ辞書でCtrと矢印をすればEnd(xup)とかのEndプロパティを調べられる。
sub データベースの特定の行を選択する31_3()
'5行目のデータを選択するとする。
'Range(左上、右下)を使うと以下。
Range("A5", Range("A5").End(xlToRight)).Select
End sub
sub エンドモードで最終データが入力されているセルに移動する33()
Dim 最終行番号 As Long: 最終行番号 = ActiveSheet.Rows.Count
Cells(最終行番号, 1).End(xlUp).Select
End sub
'
'cells(rows.Count,1).end(xlup) とは、
'activesheet.cells(acivesheet.rows.Count,1).end(xlup) のことだったのである。
'cells(i,42)と書くよりも、Cells(i,"AB")と書いた方が読みやすい。数え間違いもない。
sub データが入力されている範囲を操作する33_3()
Dim i As Long
'for next のループで操作するためにendモードを使って最終データセルに移動してからその行番号を数える。
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
' Cells(i,1)に対する処理
' Cells(i,2)に対する処理
Next i
End sub
'やりがちな間違い
' With Sheets("データベース")
' For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
' Cells(i,1)に対する処理
' Cells(i,2)に対する処理
' Next i
' End With
' 解説
' 上記の「.Cells」の親オブジェクトはデータシートなのに､
' (Rows.Count, 1).End(xlUp).Selectの「Rows.count」の親オブジェクトはactivesheetなのでズレてる。
'正しくは､rowsの前にも「.」をつけて
'With Sheets("データベース")
' For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
' Cells(i,1)に対する処理
' Cells(i,2)に対する処理
' Next i
'End With
sub 新規データを入力するセルに移動する34()
Dim 最終行番号 As Long: 最終行番号 = ActiveSheet.Rows.Count
Cells(最終行番号, 1).End(xlUp).Offset(1, 0).Select
End sub
'新規データ入力はOffsetで。
sub 新規データを入力するセルに移動する34_2()
Dim 最終行番号 As Long: 最終行番号 = ActiveSheet.Rows.Count
With Cells(最終行番号, 1).End(xlUp)
' .offset(1,0)=...
' .offset(1,1)=...
' .offset(1,2)=...
' .offset(1,3)=...
End With
End sub
指定したシート以外を削除するマクロ
1 原義シートやデータシートを使って出力シートを日次で作成した後、次に使用前に前回の出力シートを削除してから始める。
2 削除しないシート名をマクロ記述の中に含めるか、エクセルシートにマクロを使わずに書いておくか。
3 検討中
