Excelマクロのモジュールをそのまま貼り付け。
（会社とか家とか出先とかで見るため）
「Option Compare Binary」以下を標準モジュールに貼り付ければ、Myマクロ辞典に！
貼り付け後、「■Sub 」を「Sub 」に置き換えよう！
※公開している以上、利用は自由ですが、自己責任で。


Option Compare Binary
Option Explicit
'
'メッセージボックス（※オブジェクト名は ＭｓｅＢｏｘとする。）
'
'MsgBoxのアイコン
'定数 値 内容
'vbCritical 16 警告メッセージアイコン（赤丸に×）
'vbQuestion 32 問い合わせメッセージアイコン（ふきだしに？）
'vbExclamation 48 注意メッセージアイコン（黄色の三角に！）
'vbinformation 64 情報メッセージアイコン（ふきだしにｉ）
'http://www.geocities.jp/cbc_vbnet/function/mseegefunction.html
'画像→http://officetanaka.net/excel/vba/tips/tips21.htm
' http://www.excel-vba.net/excel-dialog-001.html
'
'MsgBoxのボタン
'定数 値 内容
'vbOKOnly 0 [OK]ボタンのみを表示
'vbOKCancel 1 [OK]ボタンと[キャンセル]ボタンを表示
'vbAbortRetryIgnore 2 [中止]、[再試行]、[無視]ボタンを表示
'vbYesNoCancel 3 [はい]、[いいえ]、[キャンセル]ボタンを表示
'vbYesNo 4 [はい]、[いいえ]ボタンを表示
'vbRetryCancel 5 [再試行]、[キャンセル]ボタンを表示
'vbDefaultButton1 0 第1ボタンを標準ボタンに
'vbDefaultButton2 256 第2ボタンを標準ボタンに
'vbDefaultButton3 512 第3ボタンを標準ボタンに
'vbDefaultButton4 768 第4ボタンを標準ボタンに
'
'vbApplicationModal 0 アプリケーションモーダルに設定。
' MsgBoxに応答するまで現在選択中のアプリケーションの実行を継続できない。
'vbSystemModal 4096 システムモーダルに設定。
' MsgBoxに応答するまで、すべてのアプリケーションが中断
'
'改行： Chr(10) または　vbNewLine　または　vbCr

■Sub メッセージボックスの1()

MsgBox "このモジュール（オブジェクト？）の名前は「MesBox」です。" & vbNewLine & _
"正しくは「MsgBox」ですが、実在するメソッド、アクション、プロパティ名はモジュール名には使えないのです。　　　" & vbNewLine & _
"( ﾟ－ﾟ *　　", vbInformation, "タイトル"

'MsgBox DCount("*", "A_Table") & "件を" & vbNewLine & "出力しました。( ﾟ－ﾟ *　　", vbOKCancel + vbExclamation, "タイトル"

End Sub

■Sub メッセージボックスの2()

Dim rc As VbMsgBoxResult
'Dim rc As Variant '‥Variant型でもＯＫ

rc = MsgBox("処理を続行しますか？　　　", vbYesNoCancel + vbQuestion)

If rc = vbYes Then
MsgBox "処理を続けます。　　　", vbInformation
ElseIf rc = vbNo Then
MsgBox "処理を中止します。　　　", vbCritical
Else
MsgBox "キャンセルされました。　　　", vbExclamation
End If

End Sub

■Sub メッセージボックスの表示()
'実際にマクロを実行してみて。

MsgBox "警告メッセージアイコン （vbInformation, 16）　　　", vbInformation, "警告メッセージ"
MsgBox "問い合わせメッセージアイコン （vbQuestion, 32）　　　", vbQuestion, "問い合わせメッセージ"
MsgBox "注意メッセージアイコン （vbExclamation, 48）　　　", vbExclamation, "注意メッセージ"
MsgBox "情報メッセージアイコン （vbInformation, 64）　　　", vbInformation, "情報メッセージ"

End Sub

■Sub メッセージボックスをIF文に利用する()

If vbYes = MsgBox("メッセージボックスです。　　　", vbYesNo + vbInformation, "タイトル") Then
Else
End
End If

End Sub

■Sub 自動的に閉じるメッセージボックス()

Dim WSH As Object
Set WSH = CreateObject("WScript.Shell")
WSH.Popup "5秒後、自動的に閉じます", 5, "Title", vbInformation
Set WSH = Nothing

End Sub

■Sub メッセージの表示切替()

'Otherモジュール「確認ダイアログを非表示」参照

End Sub

■Sub インプットボックス()

Dim buf As String

buf = InputBox("名前を入力してください", "名前を指定", "あなたの名前", 1000, 1000, "test.hlp", 2)
Range("A1") = buf

'InputBox(Prompt,[Title],[Default],[XPos],[YPos],[HelpFile],[Context])
'Prompt InputBoxに表示する文字列（必須）
'Title InputBoxのタイトル
'Default 最初から入力ボックスに表示しておく文字列
'XPos ダイアログボックスを表示する縦位置（ウィンドウの座標を指定）
'YPos ダイアログボックスを表示する横位置（ウィンドウの座標を指定）
'HelpFile ヘルプファイルを指定　例："test.hlp"
'Context ヘルプファイル内のページを示すコンテキストID

End Sub

Excelマクロのモジュールをそのまま貼り付け。
（会社とか家とか出先とかで見るため）
「Option Compare Binary」以下を標準モジュールに貼り付ければ、Myマクロ辞典に！
貼り付け後、「■Sub 」を「Sub 」に置き換えよう！
※公開している以上、利用は自由ですが、自己責任で。


Option Compare Binary
Option Explicit
'
'その他マクロ

■Sub ファイルの起動時にマクロを実行する()

'auto_open() ←マクロ名

MsgBox "B5をアクティブにします。　　　"
Range("B5").Activate '記述はなんでもいい

End Sub

■Sub auto_openをデバッグする()
'シングルステップで実行する場合は［f8］

Workbooks.Open("D:\My Documents\da Vinci出力\ファイル変換v1.xls").RunAutoMacros xlAutoOpen

End Sub

■Sub ファイルを閉じる時にマクロを実行する()

'Sub auto_close()
'Sub Auto_Close()　※どちらでもＯＫ
'※マクロの Closeイベントで閉じる場合、実行されない。
'※マクロの Closeイベントを実行するときは、［ThisWorkbook］のコードウィンドウに記述する。

If vbYes = MsgBox("上書き保存しますか？　　　", vbYesNo + vbQuestion, "ファイルを終了") Then
ThisWorkbook.Close True '保存して閉じる
Else
ThisWorkbook.Close False '保存しないで閉じる
End If

'※IF文の分岐内に“End”を入れても、Auto_Closeはキャンセルできないので注意。

End Sub

■Sub 確認ダイアログを非表示()

Application.DisplayAlerts = False '非表示
Application.DisplayAlerts = True '表示

End Sub

■Sub クリップボートを空にする()

Application.CutCopyMode = False

End Sub

■Sub DoEvents関数()

'発生したイベントがオペレーティングシステムによって処理されるように制御を戻します。
'DoEventsは、MS-WindowsがUNIXやLinux等のマルチタスクOSではなく、疑似マルチタスクであるため必要なものです｡
'通常マルチタスクOSでは、同時に実行される各種のプログラムに対して処理に必要な時間と順序をOSが配分して
'実行しますが、MS-Windowsではプログラムから処理が戻ってから(今回ではプロシージャが終了してから)、
'次のプログラムやキー入力、マウス入力イベント等を実行します。
'したがって､時間のかかる処理や無限ループなどがあると、他の処理が実行できなくなり、
'極端に全体の反応が遅くなったり、動かなくなったりします｡
'＃画面が白くなるのは、表示の更新が行われなくなるためです。
'そうなる事を防ぐ為、DoEventsを実行して、他のプログラムやイベント処理を実行させる必要があります｡

'【使用例】
Dim i As Variant
For i = 1 To 10
Cells(i, 3).Value = i
DoEvents '←★
Next

End Sub

■Sub DoLoop文()
'Do While 条件式 …条件式がtrueの間だけ処理を実行。
'Do Until 条件式 …条件式がtrueになるまで処理を実行。

'セルA1からシート終端セルまで、文字列"ABC"を探す
Dim i As Long

i = 1
Do While Cells(i, 1) <> "ABC"
If i = Cells.Rows.Count Then
'シート終端に達したら、ループを抜ける
Exit Do
End If
i = i + 1
Loop

End Sub

■Sub ForNext文()
'For文は繰り返しの回数が決まっているとき、
'Do文は繰り返し回数が決まっていないときに使用すると、ソースの意味がわかりやすくなります。
'For Nextで使うカウンタ変数は、アルファベット小文字の「i」「j」「k」を使うのが一般的です。

'セルA1～セルA10 に値を入力する
Dim i As Long
For i = 1 To 10
Cells(i, 1).Value = i
Next

'■増減値を指定
For i = 1 To 10 Step 2
Cells(i, 1).Value = i
Next

'■ループアウト
'Exit Forステートメントを使用すると繰り返しを抜ける事が出来ます。
For i = 1 To 10 Step 2
If myCnt = 5 Then Exit For
Cells(i, 1).Value = i
Next

End Sub

■Sub Sleepで処理を一時中断()

'Timerモジュール参照

End Sub

■Sub IF文の書き方()

Dim a As Variant
a = 10


'ふつうの書き方（処理ごとに改行）
If a = 0 Then
MsgBox "true（処理ごとに改行しています。）"
Else
MsgBox "false（処理ごとに改行しています。）"
End If


'Else文を1行に記述
If a = 0 Then
MsgBox "合ってる（Else文を1行に記述しています。）"
Else: MsgBox "間違ってる（Else文を1行に記述しています。）"
End If


'Else文を1行に記述（エラーになる例）
If a = 0 Then MsgBox "合ってる（Else文を1行に記述しています。）" '真の処理文（Then以下）は次の行にしないと×
Else: MsgBox "間違ってる（Else文を1行に記述しています。）"
End If


'すべて1行で記述（処理がそれぞれ1つの場合。End Ifは記述しない）
If a = 0 Then MsgBox "OK（すべて1行で記述）" Else MsgBox "NG（すべて1行で記述）"

If a = 0 Then MsgBox "OK（すべて1行で記述/Elseの処理なし）" 'Elseの処理がないときはこれでもいいみたい


'If Not文
If Not ActiveSheet.Name Is "Sheet1" Then MsgBox "YES（If Not文）" Else MsgBox "NO" 'If xxx <> xxx ～ だと×なときがあるみたい


'※ ElseIf を含む場合は、ふつうの書き方（処理ごとに改行）のみＯＫ
a = InputBox("数字を入れて")

If a = 1 Then
MsgBox "Yes"
ElseIf a = 2 Then
MsgBox "YesYes"
Else
MsgBox "No!"
End If

End Sub

■Sub メッセージBOXをIF文に利用する()

'MeaBoxの「メッセージBOXをIF文に利用する」参照

End Sub

■Sub CASE選択1()

Select Case Range("A1").Value
Case Is < 3 '演算した結果を比較演算子で指定（セルA1が"3未満"）
MsgBox "A"
Case 5 '値を指定（Is =　5 でもOK）
MsgBox "B"
Case 7 To 9 '演算した結果を範囲で指定（セルA1が7～9）
MsgBox "C"
Case Else '上記に当てはまらない場合（Else）
MsgBox "該当なし"
End Select

End Sub

■Sub CASE選択2()
'Select Caseステートメント

ans% = MsgBox("確認しちください♪", vbYesNoCancel)

Select Case ans%
Case vbYes
GoTo step1 '処理分岐（Yesなら行ラベル名「step1」を実行する）
Case vbNo
GoTo step2
Case vbCancel 'Case Elseでもよい
GoTo step3
End Select

step1: 'これを「ラベル（行ラベル）」と呼ぶらしい
MsgBox "step1を実行します"

'その2
Select Case 変数
Case 値1
変数 = 値1の場合の処理
Case 値2
変数 = 値2の場合の処理
Case Else
変数 = 値1､変数 = 値2を満たさなかった場合の処理
End Select

End Sub

■Sub CASE選択3_ファイル取込()

Dim ans As Variant

ans = MsgBox(f_type & "ファイルの取り込みを開始します。　　　", vbOKCancel + vbQuestion, "CSVファイルの取り込み")
Select Case ans
Case vbYes
Call CSVファイルを読み込む 'CSVファイル（集団型）を開く
Case vbNo
個別型を開く2: 'ラベル
f_type = "個別型"
If vbYes = MsgBox(f_type & "ファイルの取り込みを開始します。　　　", vbYesNo + vbQuestion, "CSVファイルの取り込み") Then
Call CSVファイルを読み込む 'CSVファイル（個別型）を開く
MsgBox "取込完了　　　", vbInformation
Exit Sub
Else
MsgBox "終了します。" & vbNewLine & f_type & "ファイルは取り込まれていません。　　　", vbInformation, "取込終了"
Exit Sub
End If

Case vbCancel
Exit Sub
End Select

GoTo 個別型を開く2

End Sub

■Sub 処理分岐_GoToステートメント()
'上記「CASE選択」も参照

MsgBox ("Gotoステートメントのテスト1")

GoTo Label1

MsgBox ("Gotoステートメントのテスト2") '→実行されない

Label1: 'これを「ラベル（行ラベル）」と呼ぶらしい
MsgBox ("Gotoステートメントのテスト3")


End Sub

■Sub 処理分岐_Callステートメント()
'プロシージャの呼び出し

Call 枠線の表示切替 '「Sub 枠線の表示切替()」を呼び出す

'※単に呼び出したいプロシージャ名を記述するだけで呼び出すこともできる
枠線の表示切替

'Gotoは、同じプロシージャ内。「処理分岐_GOTO」参照↑

End Sub

■Sub 文字コード変換()

Dim st As ADODB.Stream
Dim rowNo As Integer

On Error GoTo Err

'ADODB.Stream生成
Set st = New ADODB.Stream

'Textモード
st.Type = adTypeText

'文字コード（Shift_JIS, Unicodeなど）
st.Charset = "UTF-8"

'Streamのオープン
st.Open

'ファイル読み込み
st.LoadFromFile ("C:\test2.csv")

rowNo = 1
'ファイルの終りまでループ
Do While Not (st.EOS)
'1行読み込み（readText(adReadAll)：すべて読み込み）
Worksheets("Sheet1").Cells(rowNo, 1).Value = st.ReadText(adReadLine)
rowNo = rowNo + 1
Loop

'クローズ
st.Close
Set st = Nothing

Exit Sub

Err:
Set st = Nothing

'エラー内容
MsgBox (Err.Description)

End Sub

■Sub Debug_()
'変数の値をイミディエイトに表示

Debug.Print f_path

End Sub

■Sub Excelのバージョンを取得()

MsgBox Application.Version

'ﾊﾞｰｼﾞｮﾝ 戻り値（文字列型）
'2010 14.0
'2007 12.0
'2003 11.0
'2002 10.0
'2000 9.0
'97 8.0
'95 7.0
'5.0 5.0

End Sub

■Sub ファイルフォーマットを取得()

MsgBox ActiveWorkbook.FileFormat

'戻り値は、ヘルプ→Microsoft Visual Basic for Applications ヘルプ→「XlFileFormat 列挙」で検索、参照

End Sub

Excelマクロのモジュールをそのまま貼り付け。
（会社とか家とか出先とかで見るため）
「Option Compare Binary」以下を標準モジュールに貼り付ければ、Myマクロ辞典に！
貼り付け後、「■Sub 」を「Sub 」に置き換えよう！
※公開している以上、利用は自由ですが、自己責任で。


Option Compare Binary
Option Explicit
'VBAで他のアプリケーションを制御

■Sub 他のアプリケーションを開く()

'メモ帳
Dim NP As Double '倍精度浮動小数点数型
NP = Shell("Notepad.exe", vbNormalFocus) 'メモ帳を開く

End Sub

■Sub 他のアプリケーションでいろいろなファイルを開く()
'Shellで直接指定するのは、EXE形式のアプリケーション
'構文は：Shell アプリケーションへのフルパス＋名前 開きたいファイルのフルパス＋名前, ウィンドウ状態※, 待機有無※

'Shell関数で半角スペースを含むファイルを開く場合は、
' ファイル名をひとつの連続した文字列として認識させるために二重引用符 (") で括る
'【参考】http://officetanaka.net/excel/vba/tips/tips90.htm

Shell "C:\WINDOWS\system32\mspaint.exe ""C:\Documents and Settings\a05076\My Documents\J1000739.JPG""", vbNormalFocus
' ↑ ↑ ↑
' 関数を囲む(") ｽﾍﾟｰｽを含むﾊﾟｽを囲む("")　　　　　　　　　　　 ｽﾍﾟｰｽを含むﾊﾟｽを閉じる("")と関数を閉じる(")
'↑"が1個足りない気が‥いいのか？

'変数を利用する（パスにスペース有り）
Dim P As String
P = """C:\Documents and Settings\a05076\My Documents\J1000864.JPG"""
Shell "C:\WINDOWS\system32\mspaint.exe " & P, vbNormalFocus


'※ウィンドウ状態
'値 意味 定数作成例
'0 ウィンドウを非表示 vbHide
'1 通常のウィンドウ、かつ最前面 vbNormalFocus
'2 最小化、かつ最前面 vbMinimizedFocus
'3 最大化、かつ最前面 vbMaximizedFocus
'4 通常のウィンドウ、not最前面 vbNormalNoFocus
'6 最小化、not最前面 vbMinimizedNoFocus

'※待機有無
'True 実行したプログラムが終了するまで、スクリプトの処理を待機
' ※実行したプログラムの終了コードを参照するときは､こちらを指定してください｡
'False スクリプトの処理を続行

End Sub

■Sub 他のアプリケーションでいろいろなファイルを開くその2()

a& = Shell("c:\MSOffice\WinWord\winword.exe", 1) 'Shell関数でWordを起動しておく

Dim wobj As Object 'wobj をオブジェクト変数として宣言
Set wobj = GetObject("", "Word.Basic") 'wobjを Word.Basic のオブジェクトとして作成
wobj.fileopen ActiveCell.Value 'Word.Basic のFileopenメソッドで ActiveCell のファイルをWordで開く
Set wobj = Nothing 'オブジェクトの開放｡

End Sub

■Sub メモ帳で文字コード変換して保存()
'ファイルをメモ帳で開いて、文字コードを「ANSI」（Shift-JIS）に変更して別名保存する。
'★メモ帳で保存するファイル名が既にあると途中で止まるので注意（確認記述あり）★

Dim Path As String '元ファイルパス
Dim nFile As String 'メモ帳で開く別名保存するファイルパス
Dim eFile As String 'Excelで開くファイルパス
Dim macroF As String 'マクロブック名


On Error GoTo エラー処理


'マクロブック名を取得
macroF = ThisWorkbook.Name


'ファイルを特定
Path = Application.GetOpenFilename("すべてのファイル,*.*", Title:="ファイルを選択してください。")

If Path = "False" Then
MsgBox "キャンセルされました。　　　", vbOKOnly + vbExclamation

Application.Quit 'Excel終了（マクロが終了するまでWeitされる）
'Workbooks(macroF).Close 'マクロファイルを閉じる
'End 'マクロ終了
End If


'メモ帳で別名保存するファイルパスを取得
eFile = Left(Path, Len(Path) - 4) & "1" & Right(Path, 4)

If Dir(eFile) <> "" Then '同じファイル名がある場合は終了★
MsgBox "別名保存するファイル名（パス）が存在します。　　　" & vbNewLine & _
"下記のファイル名を変更するか、削除してください。　　　" & vbNewLine & vbNewLine & _
eFile & "　　　", vbOKOnly + vbExclamation, "ファイルの重複"

Application.Quit 'Excel終了（マクロが終了するまでWeitされる）
Workbooks(macroF).Close 'マクロファイルを閉じる
End 'マクロ終了
End If


'メモ帳で使えるようにファイル名を加工
Path = """" & Path & """" '結果："D:\My Documents\xxx.xxx"（スペースのあるパスを有効にする）
nFile = """" & eFile & """"
Debug.Print Path
Debug.Print eFile
Debug.Print nFile


'メモ帳で元ファイルを開く
Shell "C:\WINDOWS\system32\notepad.exe " & Path, vbNormalFocus


'文字コードを変更してファイルを保存
SendKeys "%fa", True '［ファイル］－［名前をつけて保存］
SendKeys nFile, True ' ファイル名を入力
SendKeys "%e", True '［文字コード］を選択
' myTime = Now + TimeSerial(0, 0, 1)
SendKeys "ANSI", True '「ANSI」を入力（Shift-JIS）
SendKeys "%s", True '［保存］
' SendKeys "%y", True
SendKeys "%fx", True '［ファイル］－［メモ帳の終了］

'SendKeys解説
'キー コード
'SHIFT +
'CTRL ^
'ALT %


MsgBox "完了しました。　　　"


Exit Sub


エラー処理:

MsgBox "エラーが発生しました。" & vbNewLine & _
"もう一度やり直してください。　　　", vbCritical, "エラー発生"
'End

Application.DisplayAlerts = False '確認メッセージを出さない
Application.Quit 'Excel終了

'※親プロシージャがある場合は、親は終了しないので、「End」を置くこと。


End Sub

■Sub テキストファイルを作成して保存()
'InputBoxでファイル名を指定

Dim intFileNum As Integer ' FreeFile値
Dim strFileName As String ' OPENするファイル名(フルパス)

intFileNum = FreeFile
strFileName = InputBox("ファイル名を指定してください")
If strFileName <> "" Then
strFileName = strFileName & ".txt"
Open strFileName For Output As intFileNum
Close #intFileNum
End If

End Sub

■Sub テキストファイルを作成して書き出し1()
'コードでファイル名を指定
'書き出す範囲をコードで指定

Dim intFileNum As Integer ' FreeFile値
Dim strFileName As String ' OPENするファイル名(フルパス)
Dim strREC As String ' 書き出すレコード内容

intFileNum = FreeFile
strFileName = "てすと.html"

Open strFileName For Output As intFileNum

strREC = Cells(1, 1).Value
Print #intFileNum, strREC ' 書き出し

Close #intFileNum

End Sub

■Sub テキストファイルを作成して書き出し2()
'書き出す範囲を取得して書き出し

Const cnsFILENAME = "\SAMPLE.txt"
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 書き出すレコード内容
Dim GYO As Long ' 収容するセルの行
Dim GYOMAX As Long ' データが収容された最終行

' 最終行の取得
GYOMAX = Range("A65536").End(xlUp).Row
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(出力モード)
Open ThisWorkbook.Path & cnsFILENAME For Output As #intFF
' 2行目から開始
GYO = 2
' 最終行まで繰り返す
Do Until GYO > GYOMAX
' A列内容をレコードにセット(先頭は2行目)
strREC = Cells(GYO, 1).Value
' レコードを出力
Print #intFF, strREC
' 行を加算
GYO = GYO + 1
Loop
' 指定ファイルをCLOSE
Close #intFF
End Sub

Excelマクロのモジュールをそのまま貼り付け。
（会社とか家とか出先とかで見るため）
「Option Compare Binary」以下を標準モジュールに貼り付ければ、Myマクロ辞典に！
貼り付け後、「■Sub 」を「Sub 」に置き換えよう！
※公開している以上、利用は自由ですが、自己責任で。


Option Compare Binary
Option Explicit
'
'shapes（画像および図形）関連

'DoEvents用の記述（ペイントの起動）
''Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

■Sub ペイントを起動()

'Declare宣言が必要。
'→Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Shell "C:\WINDOWS\system32\mspaint.exe " & """" & f_path & """", vbNormalNoFocus
Dim hwndPTApp As Long
Do While hwndPTApp = 0&
hwndPTApp = FindWindow("MSPaintApp", f_name & " - ペイント")
DoEvents
Loop
Workbooks(myFile).Activate

End Sub

■Sub 矩形を描画()

ActiveSheet.Shapes.AddShape msoShapeRectangle, 50, 50, 100, 120

'AddShape(種類, 横位置, 縦位置, 幅, 高さ).
'msoShapeRectangle　…四角形
'msoShapeOval　…楕円

End Sub

■Sub 複数の画像を選択その1()

ActiveSheet.Shapes.Range(Array("Picture 4", "Rectangle 5")).Select

End Sub

■Sub 複数の画像を選択その2()

'以下の記述でもOK
ActiveSheet.Shapes.Range(Array(3, 4)).Select

'よって、貼り付けた図形番号(図形の名前)を変数に代入しても可
Dim x As Variant
x = .Shapes.Count '図形の総数(最後に貼付られた図形番号)
ActiveSheet.Shapes.Range(Array(3, x)).Select

End Sub

■Sub 複数の画像を選択その3()

Dim Pct1 As Shape
Dim Pct2 As Shape
Set Pct1 = ActiveSheet.Shapes(1)
Set Pct2 = ActiveSheet.Shapes(2)

ActiveSheet.Shapes.Range(Array(Pct1.Name, Pct2.Name)).Select

End Sub

■Sub 複数の画像を選択その4()

Dim Pct1 As Shape
Dim Pct2 As Shape
Set Pct1 = ActiveSheet.Shapes(1)
Set Pct2 = ActiveSheet.Shapes(2)

Pct1.Select
Pct2.Select False 'Falce をつけると先に選択した画像の選択をはずさずに追加選択できる

End Sub

■Sub 図形を整列その1()

ActiveSheet.Shapes.Range(Array("Picture 4", "Rectangle 5")).Select
Selection.ShapeRange.Align msoAlignCenters, False '左右中央揃え

End Sub

Excelマクロのモジュールをそのまま貼り付け。
（会社とか家とか出先とかで見るため）
「Option Compare Binary」以下を標準モジュールに貼り付ければ、Myマクロ辞典に！
貼り付け後、「■Sub 」を「Sub 」に置き換えよう！
※公開している以上、利用は自由ですが、自己責任で。


Option Compare Binary
Option Explicit
'シート関連マクロ

■Sub シートの作成()

'ワークシートSheet2の後ろにシートを作成
ActiveWorkbook.Worksheets.Add After:=Worksheets("Sheet2")

'一番前に作成
Worksheets.Add Before:=Worksheets(1)

'一番後ろに作成
Worksheets.Add After:=Worksheets(Worksheets.Count)

'ブック名を指定してシートを作成する
Workbooks("Book1.xls").Worksheets.Add

'シートを挿入し、名前を変更する
With Worksheets.Add()
.Name = "合計"
End With

End Sub

■Sub シート名を取得()

Dim d As String
d = ActiveSheet.Name
Debug.Print d

End Sub

■Sub シート名の変更()

'現在アクティブなシートのシート名変更
ActiveSheet.Name = "チェック用"

'シート名を指定して変更
Worksheets("form_sheet").Name = Format(d, "YYYYMMDD")

End Sub

■Sub シートを選択()

'シート名を指定
Worksheets("Sheet1").Activate

'インデックス番号（シート番号）を指定
Worksheets(1).Activate

'アクティブシートの1つ左のシートを選択
ActiveSheet.Previous.Select

'アクティブシートの1つ右のシートを選択
ActiveSheet.Next.Select

'最後のシートを選択
Worksheets(Worksheets.Count).Activate

End Sub

■Sub かんたんなシート選択()
'■「シート選択」の考え方
'「シート選択ダイアログ」は、戻り値（選択したシート、キャンセルなど）がない。
'シートが選択された場合はよいが、「キャンセル」押下は判断できない。
'ので、「キャンセル」押下時は、現在のシートがアクティブになることと、
'そもそも現在のシートが表示したいなら選択ダイアログは不要だろうという前提で、
'ダイアログが閉じたときに現在のシートがアクティブなら「キャンセル」が押下られたと判断するというもの。

Dim mySH As Worksheet '現在アクティブなシート
Dim slSH As Worksheet 'シート選択ダイアログで選択したシート

Application.ScreenUpdating = False '画面リフレッシュＯＦＦ

Set mySH = ActiveSheet 'アクティブシートを取得

'シート選択ダイアログを表示（画面は動かないけど、選択したシートが ActiveSheet になる）
With CommandBars.Add(Temporary:=True)
.Controls.Add(ID:=957).Execute
.Delete
End With

Application.ScreenUpdating = True '画面リフレッシュＯＮ

'ActiveSheet（選択したシート）が元のシートと異なる：slSH に ActiveSheet をセット
'ActiveSheet（選択したシート）が元のシートと同じ Or ｷｬﾝｾﾙ押下：「キャンセルされました」
'（ｷｬﾝｾﾙ押下時は、ActiveSheet = mySH なので、slSH はセットされない＝Nothing）
'（シートの切換前提なので、元のシートを選択することはないという判断）
If Not ActiveSheet Is mySH Then 'If ActiveSheet <> mySH ～ だと×
Set slSH = ActiveSheet
slSH.Select
MsgBox "完了（・∀・）　　　", vbInformation
Else
mySH.Select
MsgBox "キャンセルされました（・ε・）　　　", vbExclamation
End If

Set mySH = Nothing
Set slSH = Nothing

End Sub

■Sub かんたんじゃないシート選択()
'「Public Function ShowSelectSheetDialog() As Worksheet」とセットです。

Dim Sh As Worksheet
Set Sh = ShowSelectSheetDialog() 'Public Function ShowSelectSheetDialog() As Worksheet を実行
If Not Sh Is Nothing Then
MsgBox Sh.Name & "が選択されました。　　　" & vbNewLine & "アクティブにします（・∀・）　　　", _
vbInformation
Sh.Activate
Else
MsgBox "キャンセルされましたよ（・ε・）　　　", vbExclamation
End If
Set Sh = Nothing

End Sub

Public Function ShowSelectSheetDialog() As Worksheet
'↑「かんたんじゃないシート選択」とセットです。

' // シート選択ダイアログを表示
' // 戻り値： 選択されたシート。元のシートと同じ、またはキャンセル時：Nothing

Dim ShBackup As Worksheet
Application.ScreenUpdating = False
Set ShBackup = ActiveSheet 'アクティブシートを取得
With CommandBars.Add(Temporary:=True) 'シート選択ダイアログ
.Controls.Add(ID:=957).Execute
.Delete
End With
' Return
If Not ActiveSheet Is ShBackup Then
Set ShowSelectSheetDialog = ActiveSheet '選択したシートが元のシートと異なる場合はセット※
End If
ShBackup.Select
Application.ScreenUpdating = True

'※ｷｬﾝｾﾙが押下された場合は、アクティブシート
'「かんたんなシート選択」参照

End Function

■Sub シートのコピー()

'現在アクティブなシートを"Sheet2"の前にコピーする
ActiveSheet.Copy Before:=Worksheets("Sheet2")

'ワークシートSheet1をコピーしSheet3の後ろに挿入する
Worksheets("Sheet1").Copy After:=Worksheets("Sheet3")

'ブック間のワークシートコピー
Workbooks("99.xls").Worksheets("Sheet1").Copy After:=Workbooks("Book4.xls").Worksheets("Sheet2")

'CSVシートをBook1.xlsxのいちばん後ろにコピーする
Sheets("CSV").Copy After:=Workbooks("Book1.xlsx").Sheets(Workbooks("Book3.xlsx").Sheets.Count)


'ワークシートを新しいブックにコピーする（Copyメソッドの引数を省略した場合は新規ブックが自動的に開いてシートがコピーされる）
Worksheets("Sheet1").Copy

'ワークシートの最後尾に新しいワークシートを挿入する
Worksheets.Add After:=Worksheets(Worksheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)

'複数のシートコピーする
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select '?
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy

End Sub

■Sub シートの移動()

'現在アクティブなシートを"Sheet2"の前に移動する
ActiveSheet.Move Before:=Worksheets("Sheet2")

'ワークシートSheet1をいちばん後ろ（右）に移動する
Sheets("Sheet1").Move After:=Worksheets(Worksheets.Count)

'ブック間移動：Sheet1をBook3というワークブック内のSheet2の左側（前）へ移動
Sheets("Sheet1").Move Before:=Workbooks("Book3.xls").Sheets("Sheet2")

Workbooks("Book1.xls").Sheets("Sheet1").Move Before:=Workbooks("Book3.xls").Sheets("Sheet2")

'※移動元または移動先のブックを保存していない場合は、ブック名に".xls"がついていないので注意

'新規ブックに移動（Moveメソッドの引数"Before:～"を省略した場合は新規ブックが自動的に開いてシートが移動される）
Worksheets("Sheet1").Move

End Sub

■Sub シートの削除()
'確認のダイアログが表示されるのを制御する。

Application.DisplayAlerts = False '非表示
ActiveSheet.Delete
Application.DisplayAlerts = True '表示

End Sub

■Sub シートの保護()

Worksheets(1).Protect Password:="pass"
Worksheets(1).Unprotect Password:="pass" '保護解除

End Sub

■Sub シート数を数える()

MsgBox "ワークシート数：" & Worksheets.Count
MsgBox "グラフシート数:" & Charts.Count
MsgBox "シート数：" & Sheets.Count

'Sheetsだと､グラフシートも含まれます｡

a = Worksheets.Count

End Sub

■Sub シートを探す()
'すべてのワークシートを表す Worksheets コレクションからひとつずつ Worksheet を取り出して名前を調べる

Dim ws As Worksheet, flag As Boolean 'Boolean＝TrueかFalse

For Each ws In Worksheets
If ws.Name = "探したシート名" Then flag = True
Next ws

If flag = True Then
MsgBox "[探したシート名]シートがあります", vbInformation
Else
MsgBox "[探したシート名]シートはありません", vbInformation
End If

'※ブックの場合は、Worksheet→Workbook、Worksheets→Workbooks

If ActiveSheet.Next Is Nothing Then
MsgBox "右端です。"
Else
MsgBox "右端ではありません。"
End If

End Sub

■Sub シートをアクティブにする()

Worksheets("貼り付けシート").Activate

If Worksheets("日付エラー").Range("A1") <> "" Then
MsgBox "日付エラーがあります。　　", vbExclamation
Worksheets("日付エラー").Activate
Else
MsgBox "　", vbExclamation
End If

End Sub

■Sub 隣りのシートを指定()

ActiveSheet.Previous.Activate '左隣のシート
ActiveSheet.Next.Activate '右隣のシート

'※アクティブシートが一番右端のシートだったとき、ActiveSheet.NextはNothingを返す。

If ActiveSheet.Next Is Nothing Then
MsgBox "右端で。"
Else
MsgBox "右端ではありません。"
End If

End Sub

■Sub 遠くのシートを指定()

Worksheets(ActiveSheet.Index + 2).Activate

'※アクティブシートが一番右端のシートだったとき

If ActiveSheet.Index = Worksheets.Count Then
MsgBox "右端です。"
Else
MsgBox "右端ではありません。"
End If

End Sub

■Sub シート名を変数に格納()
'シート名やセル番地などを変数に格納する方法（Set xx As [Application,Workbook,Worksheet,Range,Shape(画像),Window・・・]）

Dim buf As Object 'オブジェクト型変数を宣言する　"～As Worksheet"でもよい
Set buf = Worksheets("Sheet1") '変数「buf」にSheet1（Worksheetオブジェクト）を入れる
MsgBox buf.Name
buf.Tab.ColorIndex = 3 'Sheet1のシート見出し色を赤にする
Set buf = Nothing

'※オブジェクト変数－応用
Dim buf As Object 'オブジェクト型変数を宣言する　"～As Range"でもよい
Set buf = Range("A1") '変数「buf」にセルA1(Rangeオブジェクト)を入れる
MsgBox buf.Width 'セルA1の横幅(Widthプロパティ)を調べる
Set buf = Nothing

'Nothingを代入することで､変数と特定のオブジェクトとの関係を無効にして､使われていたシステムリソースおよびメモリリソースを解放する｡

End Sub

■Sub シート名とブック名を変数に格納()

Dim bk As Workbook
Dim Sh As Worksheet

Set bk = Workbooks("連絡書サンプル130607.xls")
bk.Activate

Set Sh = Worksheets("マスタ")
Sh.Activate
Range("C5").Activate

Set Sh = Nothing
Set bk = Nothing

End Sub

■Sub シートの見出しの色を変更()

Worksheets("Sheet1").Tab.ColorIndex = 3 '赤にする
Worksheets("Sheet1").Tab.ColorIndex = xlNone '色を消す

End Sub

■Sub シートの下端と右端､最下行を調べて範囲選択する()

'Cell　の　最終行と最終列を検出　を参照

End Sub