1. 連続セル範囲の選択
  2. １行置きにする行挿入（Insert）
  3. シートの追加・削除（Add,Delete）
  4. シートの複数選択（Select）
  5. 複数シートの印刷（PrintOut）
  6. 重複削除してコピー（AdvancedFilter）
  7. ブックを安全確実に開く方法（Open）
  8. ブックを閉じる（Close）
  9. 罫線を簡単に引く（Borders,BorderAround）
  10. マクロVBAの開始時と終了時に指定しておくべきApplicationのプロパティ
  11. オートフィルター（AutoFilter）
  12. 日付のオートフィルタ（AutoFilter）
  13. 印刷ダイアログを使用する（xlDialogPrint）
  14. 名前定義の一覧と削除（Name）
  15. コメントの位置移動と自動サイズ調整とフォント設定
  16. 日付の検索（配列の使用）
  17. 他ブックを開いて閉じる（Open,Close）
  18. 円グラフの色設定（Chart,SeriesCollection）
  19. ストップウォッチ（1/100秒）（Timer）
  20. 重複の無いユニークなデータ作成
  21. 棒グラフ・折れ線グラフのサンプルマクロ
  22. WEBデータの取得方法
  23. 右クリックメニューの変更（CommandBars）
  24. エクセルのアイコン取得（FaceID）
  25. 人口ピラミッドのグラフをマクロで作成
  1. 写真の取込方法について（Pictures.Insert,Shapes.AddPicture）
  2. アメブロの記事本文をVBAでバックアップする№1
  3. 1次元配列の並べ替え（バブルソート,挿入ソート,クイックソート）
  4. 2次元配列の並べ替え（バブルソート,クイックソート）
  5. 数独（ナンプレ）を解くVBAに挑戦№1
  6. 数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1
  7. 写真をサムネイルに変換して取り込む（Shapes.AddPicture）
  8. Dir関数で全サブフォルダの全ファイルを取得
  9. ブックを開いた時に指定シートを表示（Workbook_Open）
  10. ブックが閉じられる直前に保存済を確認（Workbook_BeforeClose）
  11. シートが選択された時に指定セルに移動（Worksheet_Activate）
  12. ダブルクリックで行高・列幅調整（Worksheet_BeforeDoubleClick）
  13. 英小文字が入力されたら大文字に変換（Worksheet_Change）
  14. セル選択で選択行の色を変更（Worksheet_SelectionChange）
  15. シートを名前順に並べ替える
  16. グラフで特定の横軸の色を変更し基準線を引くマクロ
  17. ブックを開かずにセル値を取得（ExecuteExcel4Macro,Excel.Application）
  18. 素数を求めるマクロ
  19. 入力規則のリスト入力を確認する
  20. 配色を使用したカラー設定を固定カラーに再設定
  21. グラフのデータ範囲を自動拡張するマクロ
  22. 指定セルに名前定義されているか判定する
  23. ナンバーリンク(パズル)を解くVBAに挑戦№1
  24. ナンバーリンクを解くVBAのパフォーマンス改善№1
  25. 数式内の不要なシート名を削除する（HasFormula）
  1. Excel2003(xls)を2007以降(xlsx,xlsm)に変換する（HasVBProject）
  2. ハイパーリンクからファイルのフルパスを取得する
  3. ボタンのテキスト名のシートへ移動（Application.Caller）
  4. Excelの表をPowerPointへ図として貼り付け
  5. 方眼紙Excelが楽に入力できるVBA
  6. 画像のトリミング（PictureFormat,Crop）
  7. CSVの読み込み方法（改の改）
  8. 数式の参照しているセルを取得する
  9. フォルダ（サブフォルダも全て）削除する、Optionでファイルのみ削除
  10. オセロを作りながらマクロVBAを学ぼう
  11. ストップウォッチ改（1/100秒）（Timer）
  12. 増殖した条件付き書式を整理統合する
  13. 条件付き書式で変更された書式を取得する
  14. 順列の全組み合わせ作成と応用方法
  15. 他ブックへのリンクエラーを探し解除
  16. Excelシートの複雑な計算式を解析するVBA
  17. Shift_JISのテキストファイルをUTF-8に一括変換
  18. CSVの読み込み方法（ジャグ配列）
  19. VBAコードの全プロシージャー・プロパティ一覧を取得
  20. VBAでのCSVの扱い方まとめ
  21. CSVの読み込み方法（ジャグ配列）（改）
  22. セル結合/解除でセル値を退避/回復
  23. セル結合なんて絶対に許さないんだからね
  24. セルの数式をネスト色分けしてコメント表示

連続セル範囲の選択

　エクセルのVBAでは、連続セル範囲の選択は頻繁に行われます。
　以下では、いろいろな記述方法を紹介します。
　 このような表で、データ部（B3～D7）を選択または消去する方法になります。
Sub test1()
　 Range(Cells(3, 2), Cells(2, 2).End(xlToRight).End(xlDown)).Select
　 End Sub
B3～B2、Ctrl+→、Ctrl+↓、の範囲になります。
　上記のように、全てのセルが埋められている場合は良いですが、
　途中に空白セルがあると、ダメですね。
　
Sub test2()
　 Cells(2, 2).CurrentRegion.Offset(1, 0).Select
　 End Sub
非常に分かりやすい記述です。
　Cells(2, 2).CurrentRegion
　これで、B2～D7のセル範囲になりますので、
　Offsetで、1行下にずらしています。
　でも1行多いですね。
　まあ、処理によってはダメですね。
　
Sub test3()
　 Cells(2, 2).CurrentRegion.Offset(1, 0).Resize(Cells(2, 2).CurrentRegion.Rows.Count - 1).Select
　 End Sub
test2のセル範囲を、正しいセル範囲にResizeしています。
　これは、完璧ですね。
　
Sub test4()
　 Range(Cells(3, 2), Cells(2, 2).CurrentRegion.Item(Cells(2, 2).CurrentRegion.Count)).Select
　 End Sub
CurrentRegionの最終セルを取得しています。
　これも、完璧ですね。
　ただ、Itemはあまり一般的ではないかも知れません。
　
Sub test5()
　 Range(Cells(3, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, Columns.Count).End(xlToLeft)).Select
　 End Sub
これは、かなり無理やりですね。
　普通こんなことしませんよね。
　この記事用にねちょっとやってみただけです。
　
Sub test6()
　 Range(Rows(3), Rows(Cells(Rows.Count, 2).End(xlUp).Row)).Select
　 End Sub
クリアするだけとかなら、これでもよいですね。
　行全体を選択しています。
　場合によっては、このような指定も必要です。
　

　Sub test7()
　 Range(Cells(3, 2), ActiveSheet.UsedRange.Item(ActiveSheet.UsedRange.Count)).Select
　End Sub
　
まあ、こんな指定もできますよね。
　クリア専用なら、これでも良いですね。
　とにかく、見出しを残して、他を全て消去するような場合ですね。
　.Selectを.Clearにすれば良いです。
　
Sub test8()
　 Range(Cells(3, 2), Cells.SpecialCells(xlLastCell)).Select
　 End Sub
これも、クリア専用になるでしょうか。
　 Intersectメソッド を使う方法も、簡単で有効な方法です。
　
Sub test9()
　 Intersect(Cells(2, 2).CurrentRegion, Cells(2, 2).CurrentRegion.Offset(1, 0)).Select
　End Sub
とても簡単ですし、完璧ですね。
　上記以外にも、方法はいろいろあります。
　また、どれが良いということではありません、ケースバイケースです。
　正確に範囲選択する必要がある場合もありますが、
　単にクリアするだけとか、新規シートにコピペするだけなら、
　多少範囲が大きくても問題ありませんので。
　 .END(・・・)
　 .CurrentRegion
　 .UsedRange
　 .SpecialCells(xlLastCell)
　これらの組み合わせで、ほとんどの連続セル範囲を指定することが出来ます。

１行置きにする行挿入（Insert）

　A列に連続データが入っているとします。
　これを１行置きにします。
　
Sub sample1()
　　　Dim i As Long
　　　For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
　　　　　Rows(i).Insert
　　　Next i
　End Sub
ポイントは下から行うことです。
　上からやると、どんどん下に追いやられてしまいます。
　（Step 2とするのもありですが、普通は下からやりましょう）
　 Cells(Rows.Count, 1).End(xlUp).Row
　これで、最終行を取得しています。
　 Rows.Count
　は、シートの全行数です。
　A列の最終行で、Ctrl+↑と操作した場合と同じになります。
　 Step -1
　 これで、1ずつカウントダウンされます。
　Stepを省略した場合は1になっています。
　１行目に連続データが入っているとして、これを１列置きにする場合は。
　
Sub sample2()
　　　Dim i As Long
　　　For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
　　　　　Columns(i).Insert
　　　Next i
　End Sub
１行置きと、ほぼ同じです。
　 Row→Column
　に変更すれば、ほぼ完成です。
　後は、
　 xlUp→xlToLeft
　に変更するだけです。

シートの追加・削除（Add,Delete）

　マクロでいろいろ処理する場合に、作業用のシートを追加し、
　このシート上で処理した結果を、他シートに反映させる等は良く使うテクニックです。
　以下、シートの新規追加です。
　

　Sub sample1()
　　　Sheets.Add
　　　ActiveSheet.Name = "新規シート"
　 '　　・・・いろいろな処理
　　　Application.DisplayAlerts = False
　　　Sheets("新規シート").Delete
　　　Application.DisplayAlerts = True
　End Sub
　
先頭に新規シートが作成されます。
　最後に新規作成する場合は、
　 Sheets.Add After:=Sheets(Sheets.Count)
　 となります。
　 ActiveSheet.Name = "新規シート"
　 シート名の変更です。
　作業用のシートなら、特に名前の変更は必要ありません。
　 Application.DisplayAlerts = False
　シートを削除するときに出るアラートメッセージの表示を止めています。
　 Sheets("新規シート").Delete
　シートの削除です。
　オブジェクト変数を使用すると
　

　Sub sample2()
　　　Dim NewSht As Worksheet
　　　Set NewSht = Sheets.Add
　　　NewSht.Name = "新規シート"
　 '　　・・・いろいろな処理
　　　Application.DisplayAlerts = False
　　　NewSht.Delete
　　　Application.DisplayAlerts = True
　End Sub
　
こちらの方がスマートでしょうかね。
　新規シートを最後に追加する場合は、
　 Set NewSht = Sheets.Add(After:=Sheets(Sheets.Count))
　
　引数を()の中に入れる必要があります。
　オブジェクト変数に直接入れる場合は、このように記述します。
　これは、
　 Sheets.Add After:=Sheets(Sheets.Count)
　 Set NewSht = ActiveSheet
　これと同じことになります。

シートの複数選択（Select）

　複数のシートの選択方法です。
　シート名は、「Sheet1」「Sheet2」「Sheet3」とします。
　まずは、マクロの記録と同じように。
　
Sub sample1()
　　　Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
　End Sub
シート名がわかっていれば、これで良いですが、シート名が不明な場合は困ります。
　その場合は、
　
Sub sample2()
　　　Dim selSht As Variant
　　　Dim i As Long
　　　ReDim selSht(1 To Sheets.Count)
　　　For i = 1 To Sheets.Count
　　　　　selSht(i) = Sheets(i).Name
　　　Next i
　　　Sheets(selSht).Select
　End Sub
上記では、全シートを選択しています。
　 selShtは意図的にVariantにしています。
　Dim selSht() As String
　これでも、この場合は大丈夫です。
　しかし、
　 Arrayはバリアント型を返す関数 なので、同じにしています。
　（バージョンによって、シート以外のSelectではエラーになる場合があります）
　こんな方法もあります。
　
Sub sample3()
　　　Dim mySht As Variant
　　　For Each mySht In Sheets
　　　　　mySht.Select False
　　　Next
　End Sub
.Select False
　は、それまでの選択を有効にして、追加でSelectします。
　そうですね、 Ctrlを押して選択した時の動作 になります。
　従って、特定のシートを選択する場合は、
　最初のSelectには、Falseを指定しないようにします。
　余談ですが、
　 オートシェイプのShape.Selectにも、このFalse指定は使えます。
　ただ、残念ですが、Rangeには使用できません。
　しかし、単純に、全シートを選択するのなら、
　
Sub sample4()
　　　Sheets.Select
　End Sub
これで全シートが選択されます。
　コレクションと呼ばれる、○○○sのように、最後にsが付くものは、
　通常は、○○○s(1)のように指定します。
　そして、コレクション全体を指定する場合は、()を省略するのが基本です。

複数シートの印刷（PrintOut）

　複数シートの印刷方法です。
　シートは、ワークシートが「Sheet1」「Sheet2」「Sheet3」があり、その他で、グラフシートもあるとします。
　ワークシートのみ印刷する場合です。
　
Sub sample1()
　　　Sheets(Array("Sheet1", "Sheet2", "Sheet3")).PrintOut
　End Sub
シート名がわかっていれば、これで良いですが、シート名が不明な場合は困ります。
　その場合は、
　
Sub sample2()
　　　Dim i As Integer
　　　Dim mySht As Variant
　　　For Each mySht In ActiveWorkbook.Sheets
　　　　　If TypeName(mySht) = "Worksheet" Then
　　　　　　　mySht.PrintOut
　　　　　End If
　　　Next
　End Sub
TypeName(mySht) = "Worksheet"
　これで、ワークシートかの判定をしています。
　ただし、 この場合は、プリントスプールが別々 になります。
　 共有プリンターで印刷する場合は、他の人の印刷と混ざってしまう可能性があります。
　そこで、１つのスプールで印刷する場合は、
　

　Sub sample3()
　　　Dim mySht As Variant
　　　Dim i As Long
　　　For i = 1 To Sheets.Count
　　　　　If TypeName(Sheets(i)) = "Worksheet" Then
　　　　　　　If IsEmpty(mySht) Then
　　　　　　　　　ReDim mySht(0)
　　　　　　　Else
　　　　　　　　　ReDim Preserve mySht(UBound(mySht) + 1)
　　　　　　　End If
　　　　　　　mySht(UBound(mySht)) = Sheets(i).Name
　　　　　End If
　　　Next i
　　　If Not IsEmpty(mySht) Then
　　　　　Sheets(mySht).PrintOut
　　　End If
　End Sub
　
配列の使い方はいろいろあります。
　Dim mySht() As String
　としても良いです。
　その場合は、IsEmpty(mySht)での判定はできませんので、適時修正が必要です。
　また、mySht(1 To ・・・)として、1から使用するのも良いでしょう。
　一応、ワークシートが無かった時の判定も入れていますが、普通は不要だと思います。
　配列を使用せずに、以下のような方法も、
　

　Sub sample4()
　　　Dim mySht As Variant
　　　Dim FirstFlg As Boolean
　　　FirstFlg = False
　　　For Each mySht In ActiveWorkbook.Sheets
　　　　　If TypeName(mySht) = "Worksheet" Then
　　　　　　　If FirstFlg = False Then
　　　　　　　　　mySht.Select
　　　　　　　　　FirstFlg = True
　　　　　　　Else
　　　　　　　　　mySht.Select False
　　　　　　　End If
　　　　　End If
　　　Next
　　　If FirstFlg = True Then
　　　　　ActiveWindow.SelectedSheets.PrintOut
　　　End If
　End Sub
　
Select False
　を使用しています。
　Falseを指定することで、それまでの選択を有効に残しています。
　ここまでで、Forと、For Eachを使っていますが、特に使い分けしているわけではありません。
　サンプルとして、２通りを例示しているにすぎませんので、承知おき下さい。
　もちろん、全てのシートを印刷するなら、
　
Sub sample5()
　　　ActiveWorkbook.PrintOut
　End Sub
これで良いですね。

重複削除してコピー（AdvancedFilter）

　重複データを排除して、別シートにコピーする場合です。
　以下の表で説明します。
　 フィルターオプションを使います。
　
Sub sample1()
　　　Worksheets("Sheet1").Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
　　　　　CopyToRange:=Worksheets("Sheet2").Range("A1"), Unique:=True
　End Sub
このマクロは、
　 この指定と同じになりります。
　似たような方法ですが、コピー部分を自分で記述する場合です。
　
Sub sample2()
　　　Worksheets("Sheet1").Range("A:B").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　Worksheets("Sheet1").Range("A1").CurrentRegion.Resize(, 2).SpecialCells(xlCellTypeVisible).Copy _
　　　　　　　Worksheets("Sheet2").Range("A1")
　　　Worksheets("Sheet1").ShowAllData
　End Sub
SpecialCells(xlCellTypeVisible)
　これは、省略しても動作は同じですが、指定することをお勧めします。
　フィルター結果の見えているセルのみコピーしていると分かり易いので。
　 Worksheets("Sheet1").ShowAllData
　 フィルターで非表示になっている行を再表示しています。
　フィルター機能を使用せず、全て自力でやってみましょう。
　
Sub sample3()
　　　Dim oldCode() As Variant
　　　Dim i As Long, j As Long
　　　Dim ws2 As Worksheet
　　　Set ws2 = Worksheets("Sheet2")
　　　With Worksheets("Sheet1")
　　　　　ReDim oldCode(1 To 2)
　　　　　ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, 2)).Value = .Range(.Cells(1, 1), .Cells(1, 2)).Value
　　　　　j = 2
　　　　　For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　　　　If oldCode(1) <> .Cells(i, 1) Or _
　　　　　　　　　oldCode(2) <> .Cells(i, 2) Then
　　　　　　　　　ws2.Cells(j, 1) = .Cells(i, 1)
　　　　　　　　　ws2.Cells(j, 2) = .Cells(i, 2)
　　　　　　　　　oldCode(1) = .Cells(i, 1)
　　　　　　　　　oldCode(2) = .Cells(i, 2)
　　　　　　　　　j = j + 1
　　　　　　　End If
　　　　　Next i
　　　End With
　End Sub
もしこのような事をする必要があるとすれば、
　重複の判定が複雑で、単純なフィルターで出来ない場合になるかと思います。
　IF文の判定ですので、色々と複雑な条件を指定できます。
　ただ、そんな場合でも、作業列を追加し、単純なフィルターが適用できるよう工夫することが重要です。

ブックを安全確実に開く方法（Open）

　マクロVBAの中で、他のブックを開く事はよくあります、
　ブックを開く時、
　ブックが存在しているか、
　既に開いてないか
　これらのチェックをせずに開いてしまうと、マクロがエラー停止してしまいます。
　ここでは、これらのチェック方法についての具体的なVBAコードを紹介します。
　Openメソッドの詳細については、 ブックを開く（Open） こちらを参照してください。
　他のブックを開く方法です、しかし、これが結構いろいろあるのです。Excelで開くことが出来るファイルはCSV等のテキストファイルもありますが、ここではエクセルファイル限定で説明します。テキストファイルやCSVについては、別の記事を参考にして下さい。
　

　Sub Bookを開く()
　　　Dim wb As Workbook
　　　Dim buf As String
　　　Dim BookPath As String
　　　BookPath = "C:\Book1.xls"
　 'ブックの存在チェック
　　　buf = Dir(BookPath)
　　　If buf = "" Then
　　　　　MsgBox BookPath & vbCrLf & "は存在しません。"
　　　　　Exit Sub
　　　End If
　 '同名ブックのチェック
　　　For Each wb In Application.Workbooks
　　　　　If wb.Name = buf Then
　　　　　　　wb.Activate '指定ブックに移動
　　　　　　　MsgBox buf & vbCrLf & "は既に開いています"
　　　　　　　Exit Sub
　　　　　End If
　　　Next
　 'イベントを停止
　　　Application.EnableEvents = False
　 'ブックを開く
　　　Workbooks.Open BookPath
　　　Application.EnableEvents = True
　End Sub
　
要点は、
　 ・ブックの存在チェック
　・同名ブックのチェック
　
　この２点です。
　特に、
　エクセルでは、別ファイルでも、同一名称のブックは２重に開くことが出来ません。
　この間違いは、マクロのテスト中は良くやってしまいます。
　このようにしておけば安心です。
　また、
　Application.EnableEvents = False
　これは、開いたブックにWorkbook_Openマクロがあった場合で、それを起動したくない場合の指定です。

ブックを閉じる（Close）

　ブックを閉じる時の処理方法です。
　まずは、保存して閉じる場合。
　
Sub sample1()
　　　ThisWorkbook.Save
　　　ThisWorkbook.Close
　End Sub
これは、次のように書くこともできます。
　
Sub sample2()
　　　ThisWorkbook.Close SaveChanges:=True
　End Sub
では、保存しないで閉じる場合。
　
Sub sample4()
　　　ThisWorkbook.Close SaveChanges:=False
　End Sub
これは、次のように書くこともできます。
　
Sub sample3()
　　　ThisWorkbook.Saved = True
　　　ThisWorkbook.Close
　End Sub
ThisWorkbook.Saved
　は、最後に保存された状態から変更されていない場合は、True入っています。
　このプロパティを設定します。
　保存が必要か判定する場合。
　
Sub sample5()
　　　If ThisWorkbook.Saved = False Then
　　　　　ThisWorkbook.Save
　　　End If
　　　ThisWorkbook.Close
　End Sub
ThisWorkbook.Saved
　で、最後に保存された状態から変更されているか判断します。

罫線を簡単に引く（Borders,BorderAround）

　エクセルでは、罫線を引く事が多いです。
　この罫線は、以外に処理時間もかかりますし、やり方によっては、VBAの行数も多くなります。
　とにかく、簡単に罫線を引く方法です。
　以下の表を作成する場合です。
　 罫線を引く順番等、いろいろありますが、とにかく短いコードにしてみます。
　
Sub sample1()
　Range("B2:F11").Borders().Weight = xlHairline
　Range("B2:F11").BorderAround Weight:=xlMedium
　Range("B3:F3").Borders(xlEdgeTop).Weight = xlThin
　Range("C2:C11").Borders(xlEdgeLeft).Weight = xlThin
　End Sub
Range("B2:F11").Borders().Weight = xlHairline
　 極細線で、格子を作成
　 Range("B2:F11").BorderAround Weight:=xlMedium
　 外枠を、中太線にします。
　このBorderAround は、メソッドですので、他とは記述方法が違いますので、注意して下さい。
　 Range("B3:F3").Borders(xlEdgeTop).Weight = xlThin
　 上だけ、細線にします。
　 Range("C2:C11").Borders(xlEdgeLeft).Weight = xlThin
　 左だけ、細線にします。
　罫線を引く順序は、どの順番でも問題はありません。
　 なるべく、セル範囲を、まとめて指定するように心がけて下さい。

マクロVBAの開始時と終了時に指定しておくべきApplicationのプロパティ

　マクロVBAの開始時および終了時に指定した方が良いApplicationのプロパティの開設です。
　特に重要なもの、マクロVBAの処理速度に関係するものを紹介します。
　Applicationのプロパティの詳細については以下をご覧ください。。
　 第57回.Applicationのプロパティ（マクロ高速化と警告停止等）
　Applicationは、Excel全体をあらわすオブジェクトです、つまり、エクセルそのものだと考えて下さい。ここでは、そのプロパティの一部を紹介します。ここで紹介するApplicationのプロパティはほんの一部です。
　 Applicationのプロパティ、メソッド、イベントの一覧
　エクセルそのものである、Applicationオブジェクトのプロパティ、メソッド、イベントの一覧です。数も多く全てを覚えるようなもので はありません、必要に応じて調べて使う一覧になります。ただし、どのようなものがあるかを、ざっと目を通しておくと後々役立つことも多いでしょう。

マクロVBA開始時


　
Sub マクロ開始()
　　　Application.ScreenUpdating = False '画面描画を停止
　　　Application.EnableEvents = False 'イベントを抑止
　　　Application.DisplayAlerts = False '確認メッセージを抑止
　　　Application.Calculation = xlCalculationManual '計算を手動に
　End Sub

マクロVBA終了時


　
Sub マクロ終了()
　　　Application.StatusBar = False 'ステータスバーを消す
　　　Application.Calculation = xlCalculationAutomatic '計算を自動に
　　　Application.DisplayAlerts = True '確認メッセージを開始
　　　Application.EnableEvents = True 'イベントを開始
　　　Application.ScreenUpdating = True '画面描画を開始
　End Sub

Applicationのプロパティ解説

Application.ScreenUpdating ・・・ 画面表示の更新を制御
　マクロVBAの実行中に画面表示の更新を止めて、マクロを高速に処理されるようにします。
　マクロの先頭の方で、
　 ScreenUpdating = False
　こうすることで、マクロ実行中の画面表示が更新されないので、
　その画面更新にかかる時間が不要になり、それだけ早く処理が終了します。
　マクロが終了すると、自動的に画面表示が更新されますが、
　マクロの最期で、
　 ScreenUpdating = True
　として、明示的に書いておく方が良いでしょう。
　 Application.Calculation ・・・ 計算方法の設定
　計算モードを変更します。
　設定値
　 xlCalculationAutomatic：自動
　xlCalculationManual：手動
　xlCalculationSemiautomatic：データテーブル以外の自動
　 Calculation = xlCalculationManual
　この記述をすることで、
　これ以降、自動計算は行われなくなります。
　この設定は、マクロ終了後も引き続き有効となりますので、
　マクロVBA終了時に、
　 Calculation = xlCalculationAutomatic
　に戻しておきます。
　 Application.StatusBar ・・・ ステータスバーの文字列を設定
　マクロVBA内で、ステータスバーを使用していなければ、不要です。
　ステータス バーに文字列を設定します。
　 StatusBar = "文字列"
　これで、ステータスバーに文字列が表示されます。
　ステータス バーの文字列を既定値に戻すには、
　 StatusBar = False
　とすることで、それまでに表示していた文字列は消されます。
　 Application.EnableEvents ・・・ イベントの発生の制御
　イベント処理を使用しない場合は、不要です。
　 Application.EnableEvents = False
　これで、新たなイベント発生が停止されます。
　 Worksheetのイベントプロシージャー｜マクロVBA入門
　Worksheetのイベントプロシージャーは、ワークシートまたはそのセルに対し特定の操作（これがイベント）が行われた時に実行されます。 イベントは、手動でもVBAでも、どちらで操作が行われても発生します。Worksheetのイベントプロシージャーの一覧紹介と主要なイベントについて 解説します。
　特に、WorksheeetのChangeを使用する場合、
　イベント発生を停止しておかないと、VBAでセル値を変更しても新たにWorksheet_Changeが実行されてしまいます。
　結果的に、イベントの連鎖が起こり、無限ループが発生してエラーとなります。
　この設定は、マクロ終了後も引き続き有効となりますので、
　マクロVBA終了時に、
　 Application.EnableEvents = True
　これで、新たなイベント発生が発生するようになります。
　これを入れ忘れると、プロシージャー終了後も新たなイベントが発生しなくなります。
　もしマクロが途中でストップしてしまい、マクロ終了が実行されなかった場合は、
　手動で、マクロ終了のプロシージャーを実行するようにして下さい。
　上記以外にも、開始終了時に指定するものはありますが、
　とりあえず、このくらいを押さえておけば問題ないでしょう。

オートフィルター（AutoFilter）

　エクセルでは、定番機能のフィルターです。
　「Sheet1」のA列でフィルターし、「Sheet2」へコピーします。
　

　Sub sample()
　　　Dim FilterRange As Range
　　　With Worksheets("Sheet1")
　　　　　Set FilterRange = .Range("A1").CurrentRegion
　　　End With
　　　FilterRange.AutoFilter Field:=1, Criteria1:="○×△"
　　　With Worksheets("Sheet2")
　　　　　.UsedRange.ClearContents
　　　　　FilterRange.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
　　　End With
　End Sub
　
ごく基本的なフィルターです。
　フィルターのセル範囲指定は、いろいろな指定が可能です。
　「 連続セル範囲の選択
　エクセルのVBAでは、連続セル範囲の選択は頻繁に行われます。以下では、いろいろな記述方法を紹介します。このような表で、データ部（B3～D7）を選択または消去する方法になります。B3～B2、Ctrl+→、Ctrl+、の範囲になります。
　」も参考にして下さい。
　SpecialCells(xlCellTypeVisible)
　この指定を省略しても結果は同じですが、フィルターされた結果をコピーしている事を明示しています。
　既に、フィルターされている場合に、一度フィルターを解除する場合は、
　

　Sub sample2()
　　　If ActiveSheet.AutoFilterMode Then
　　　　　ActiveSheet.AutoFilter
　　　End If
　 '通常のフィルター処理を行う
　End Sub
　
フィルターが設定されていて、既に絞り込み等がされている可能性がある場合は、
　上のように、一度フィルターを解除してから、再度フィルターを設定して下さい。

日付のオートフィルタ（AutoFilter）

　とても便利なオートフィルターですが、日付となると、結構大変です。
　以下の表で説明します。
　 普通は、こんなように指定します。
　
Sub Macro1()
　　　Range("A1").Select
　　　Selection.AutoFilter
　　　ActiveSheet.Range("$A$1:$B$11").AutoFilter Field:=1, Operator:= _
　　　　　xlFilterValues, Criteria2:=Array(2, "6/5/2011")
　End Sub
Operator:= xlFilterValues
　
　は2007以降で追加された機能です。
　複数選択する場合の指定です。
　
　
　 Criteria2:=Array(2, "6/5/2011")
　 これが問題ですね。
　Arrayは配列です。
　例えば、複数日付を選択する場合は、
　 Criteria2:=Array(2, "6/5/2011", 2, "6/6/2011")
　
　となります。
　日付の指定が、日/月/年、になっていますが、。
　普通に、 年/月/日、の指定で良いです。
　 2, "6/5/2011"
　は、指定の日付の日になります、
　 0は、年
　 1は、月
　 2は、日
　でフィルタされるのです。
　 2003では、
　

　Sub Macro1()
　　　Range("A1").Select
　　　Selection.AutoFilter
　　　Selection.AutoFilter Field:=1, Criteria1:="2011/6/5"
　End Sub
　
いずれにしても、セルの表示書式によっては、正しくフィルターされません。
　その為、結構苦労した人は多いのではないでしょうか。
　 最も簡単な解決策は、Criteriaに指定する値を、セルの表示書式に合わせる。
　これが最も多く利用されていると思われます。
　以下のようなプログラムになります。
　
Sub Macro1()
　　　ActiveSheet.Range("$A$1:$B$11").AutoFilter Field:=1, _
　　　　　Criteria1:=Format(CDate("2011/6/5"), Range("A2").NumberFormatLocal)
　End Sub
これでも良いのですが、行によって、表示書式が違っていたりすると、間違った抽出をしてしまうことになります。
　重要なデータだったら困りますよね。
　もちろん、途中で表示書式が違うようなエクセルは作成するべきではありませんが、
　たまたま、そうなっていた事で、重大なデータ漏れを発生させるわけにはいきません。
　このやり方をする場合は、フィルタの前に、 表示書式を整えておく必要があります 。
　 表示書式を変更せずに、そのままでも正しく抽出するには、
　以下のような方法もあります。
　
Sub Macro1()
　　　ActiveSheet.Range("$A$1:$B$11").AutoFilter Field:=1, _
　　　　　Criteria1:=">=" & CLng(CDate("2011/6/5")), _
　　　　　Operator:=xlAnd, _
　　　　　Criteria2:="<=" & CLng(CDate("2011/6/5"))
　End Sub
CLng(CDate("2011/6/5")
　
　ここは、直接セルを参照する場合は、 セル.Value2 で良いです。
　
　
　ちょっと面倒ですが、これなら、全てのバージョンで正しく動作します。
　恐らく、ネットで検索しても、なかなか良い解決策が提示されていないのではないかと思います。
　特に、日付はやっかいです。
　ただし、この指定では、飛び飛びの日付や数値を指定ができません。
　そのような場合は、前出の書式を合わせる方法を使用して下さい。
　とにかく、日付は面倒でやっかいです、その事だけは覚えておいて対処しましよう。

印刷ダイアログを使用する（xlDialogPrint）

　入力しやすいように、セルに色をつけている事が多いと思いますが、
　印刷時には、ちょっとじゃまな場合もあります。
　インク（トナー）も無駄ですしね。
　印刷時に色指定を解除して印刷する方法になります。
　
Sub sample()
　　　Dim rtn As Boolean
　　　ActiveSheet.Copy
　　　ActiveSheet.Cells.Interior.Color = xlNone
　 rtn = Application.Dialogs(xlDialogPrint).Show
　 　　ActiveWorkbook.Close SaveChanges:=False
　　　Select Case rtn
　　　　　Case True
　　　　　　　MsgBox "印刷されました。"
　　　　　Case False
　　　　　　　MsgBox "印刷がキャンセルされました。"
　　　End Select
　End Sub
Application.Dialogs(xlDialogPrint).Show
　 印刷タイアログを表示します。
　プリンター等、その都度自由に選択できますので、便利だと思います。
　他は、シートをコピーし、色指定を消しているだけです。
　上記マクロをボタン等に割り当てれば、便利に使えると思います。
　先日、ツィッターで、
　ブック印刷時に、特定のシートを印刷したくない、でもプリンターは選択したい、
　というツイートを見ましたが、
　その場合は、以下のマクロで良いでしょう。
　
Sub sample2()
　　　Dim rtn As Boolean
　　　Dim strSht As Variant
　　　Dim i As Integer
　　　strSht = Array("印刷しないシート1", "印刷しないシート2")
　　　For i = LBound(strSht) To UBound(strSht)
　　　　　Sheets(strSht(i)).Visible = False
　　　Next i
　 rtn = Application.Dialogs(xlDialogPrint).Show
　 　　For i = LBound(strSht) To UBound(strSht)
　　　　　Sheets(strSht(i)).Visible = True
　　　Next i
　　　Select Case rtn
　　　　　Case True
　　　　　　　MsgBox "印刷されました。"
　　　　　Case False
　　　　　　　MsgBox "印刷がキャンセルされました。"
　　　End Select
　End Sub
このマクロをお好きなボタンに設定すれば完了です。
　印刷ダイアログを使用すれば簡単に解決できますね。

名前定義の一覧と削除（Name）

　名前定義は使い方によっては、とても便利な機能ですが、
　長く使っているブックでは、とても多くの名前定義が入ってしまっていたり、
　参照エラーを起こしている名前定義が多数あったりと、管理に困る場合も多々出てきます。
　これらが発生する原因としては、
　ブック間のシートコピーで増えていってしまったり、
　シートおよびセルの削除によって参照エラーになったままにしておくことで、
　後々に見た時に何の名前定義かさえも分からなくなってしまったりします。

名前定義の一覧を取得し、シートに書き出すマクロVBA


　
Sub sample()
　　　Dim nm As Name
　　　Dim i As Long
　　　i = 1
　　　For Each nm In ActiveWorkbook.Names
　　　　　Cells(i, 1) = nm.Name
　　　　　Cells(i, 2) = "'" & nm.Value
　　　　　Cells(i, 3) = nm.Parent.Name
　　　　　i = i + 1
　　　Next
　End Sub
Cells(i, 1) = nm.Name
　 名前定義の名前です。
　 Cells(i, 2) = "'" & nm.Value
　 名前定義の参照範囲です。
　.Valueは.RefersToや.RefersToR1C1等でも良いです。
　 Cells(i, 3) = nm.Parent.Name
　 範囲がブックと、シートがありますので、
　親オブジェクトを出力しています。
　名前の範囲がブックの場合はブック名、シート範囲の場合はシート名が出力されます。

非表示の名前定義を表示


　
Sub sample2()
　　　Dim nm As Name
　　　For Each nm In ActiveWorkbook.Names
　　　　　nm.Visible = True
　　　Next
　End Sub
nm.Visible = True
　これで表示しています。
　このVBAでは、元が表示/非表示に関わらず全て表示にしています。
　 名前定義を削除する
　
Sub sample3()
　　　Dim nm As Name
　　　On Error Resume Next
　　　For Each nm In ActiveWorkbook.Names
　　　　　nm.Delete
　　　Next
　　　On Error GoTo 0
　End Sub
古くから引き継いでいるブック等では、削除できない名前定義が存在していることが多々あります。
　その時には、エラーになってしまう為、
　On Error Resume Next
　これで、エラーを無視するようにしています。
　VBAで削除できずに残ってしまう名前定義は、先の非表示の名前定義を表示を実行してから、エクセルの名前の管理で削除してみてください。
　全てではなく、参照エラーとなっている名前定義だけ削除する場合は、
　
Sub sample4()
　　　Dim nm As Name
　　　On Error Resume Next
　　　For Each nm In ActiveWorkbook.Names
　　　　　If nm.Value Like "*[#]REF!*" Then
　　　　　　　nm.Delete
　　　　　End If
　　　Next
　　　On Error GoTo 0
　End Sub
参照範囲の文字列を判定することで、他ブックを参照している名前定義だけを削除する等、いろいろなパターンに変更可能でしょう。
　さらに極めてまれですが、
　ブックの共有等（原因ははっきりしませんが）で、数万以上の名前定義が存在していることがあります。
　そのようなブックにおいては、For Eachがエラーとなってしまい処理できない場合もあります。
　このような場合は、以下のようにしてください。
　
Sub sample5()
　　　Dim i As Long
　　　On Error Resume Next
　　　For i = 1 To ActiveWorkbook.Names.Count
　　　　　ActiveWorkbook.Names(i).Delete
　　　Next
　　　On Error GoTo 0
　End Sub
これでも削除できないような場合は、VBAでの対応は難しいと思われます。

サイト内の関連ページ

第92回.名前定義（Names）｜VBA入門
　名前定義をマクロVBAで扱う場合の解説になります、名前定義は、複数セル範囲や単一セルに対して名前を付けることで、そのセル範囲を参照する 時に名前で参照できるようにするものです。名前で参照できることで、セル位置（行位置、列位置）を固定値で指定しなくて済むようになります。
　 指定セルに名前定義されているか判定する
　名前定義は、VBAでは、セル位置の特定において重要な役割を持ちます、あるセルが名前定義されているか判定するVBAになります。ここでは、 名前定義されている場合は、その名前定義を削除するVBAサンプルとしています。指定セル範囲が何らかの名前定義に含まれているか Subsample1(rngAsRange) DimnmAsName ForEachnmInNam…

コメントの位置移動と自動サイズ調整とフォント設定

　コメントの位置をセルの横にぴったりくっつけて、サイズし入力文字列に応じて自動サイズ調整に設定します。
　正直言って、そんなに使い道があるとは思えませんが、ごくたまに必要にる場合も出てきます。
　そもそも、この位置はコメントの表示で、常時表示する場合の位置です。
　コメント非表示でのポップアップ位置ではありませんので、この点は理解しておいてください。

コメントの位置移動と自動サイズ調整とフォント設定のVBA


　
Sub sample()
　　　Dim myRange As Range
　　　For Each myRange In Cells.SpecialCells(xlCellTypeComments)
　　　　　With myRange.Comment.Shape
　　　　　　　.Top = myRange.Top
　　　　　　　.Left = myRange.Offset(, 1).Left
　 '以下でも同じ
　 '.Left = myRange.Left + myRange.Width
　　　　　　　.TextFrame.AutoSize = True
　　　　　　　.TextFrame.Characters.Font.Size = 11
　　　　　　　.TextFrame.Characters.Font.Color = vbBlue
　　　　　End With
　　　Next
　End Sub

コメントの位置移動と自動サイズ調整とフォント設定の解説

Cells.SpecialCells(xlCellTypeComments)
　 コメントのあるセルを取得しています。
　コメントの位置をセルの位置に合わせるには、
　注意点は、Commentオブジェクトの下のShapeオブジェクトの位置を指定します。
　自動サイズに設定するには、
　さらに下のTextFrameオブジェクトのプロパティのAutoSizeを設定します。
　フォントの設定は、
　さらに下のCharactersオブジェクトの下のFontのプロパティを設定する必要があります。

日付の検索（配列の使用）

　日付の検索は、いろいろと面倒です。
　Findメソッドで検索する場合、表示書式に左右されますので、
　表示書式を変更しただけで、検索されなくなります。
　これは、手作業での検索においても同様になりますが、マクロとしてはいかにも不便です。
　以下のように、配列を自分で探すようにすれば、このような問題は発生しません。
　
Sub sample()
　　　Dim i As Long, j As Long
　　　Dim ary
　　　ary = ActiveSheet.UsedRange
　　　For i = LBound(ary, 1) To UBound(ary, 1)
　　　　　For j = LBound(ary, 2) To UBound(ary, 2)
　　　　　　　If ary(i, j) = Date Then
　　　　　　　　　ActiveSheet.UsedRange.Cells(i, j).Select
　　　　　　　　　Exit Sub
　　　　　　　End If
　　　　　Next j
　　　Next i
　End Sub
まあ、ちょっと面倒ですが、確実に検索するためには仕方ありません。
　上記をコピペして、検索条件のIF文だけ変更すれば、いろいろと用途が広がると思います。

他ブックを開いて閉じる（Open,Close）

　他のブックを開いて、何らかの処理（転記等）をして、閉じる。
　よくあるパターンですね。
　簡単にサンプルのみ掲載します。
　
Sub sample1()
　　　Dim strBookName As String
　　　Workbooks.Open "ブックのフルパス"
　　　strBookName = ActiveWorkbook.Name
　　　・・・処理
　　　Workbooks(strBookName).Close SaveChanges:=False
　End Sub

　
Sub sample2()
　　　Dim wb As Workbook
　　　Set wb = Workbooks.Open("ブックのフルパス")
　　　・・・処理
　　　wb.Close SaveChanges:=False
　End Sub
保存が必要な時は、SaveChanges:=Trueとして下さい。
　オブジェクト変数が理解できるなら、sample2の方がスマートではあります。
　・・・処理
　の部分で、Withを使うなら、どちらも大差ありません。
　ついでに、開いているブックを、ブック名で検索し、閉じる場合です。
　
Sub sample3()
　　　Dim i As Integer
　　　For i = 1 To Workbooks.Count
　　　　　If Workbooks(i).Name Like "*○○○*.xls" Then
　　　　　　　Workbooks(i).Close SaveChanges:=False
　　　　　End If
　　　Next i
　End Sub

　
Sub sample4()
　　　Dim wb As Workbook
　　　For Each wb In Workbooks
　　　　　If InStr(wb.Name, "○○○") > 0 Then
　　　　　　　wb.Close SaveChanges:=False
　　　　　End If
　　　Next
　End Sub
これも、オブジェクト変数を使うかの違いと、
　Likeでワイルドカードを使う場合と、InStrで文字列位置を取得するかの違いです。
　この辺は、好みによって使い分ければ良いでしょう。

円グラフの色設定（Chart,SeriesCollection）

　 円グラフの色を、元の表から設定します。
　以下は、ウイザードでグラフを作成した状態です。
　 A列に指定した、塗りつぶし色を、グラフに反映させます。
　
Sub sample()
　　　Dim i As Long
　　　With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
　　　　　For i = 1 To .Points.Count
　　　　　　　.Points(i).Interior.Color = Cells(i + 1, 1).Interior.Color
　　　　　Next i
　　　End With
　End Sub
たった、これだけです。
　手作業よりは、はるかに簡単ですし、応用範囲が広いと思います。
　以下は、実行結果です。
　

ストップウォッチ（1/100秒）（Timer）

　ストップウォッチを作ってみましょう。
　機能は簡単に、
　・ボタンを押すと、0からスタートし時間表示が進む。
　・もう一度ボタンを押すとストップする。
　これだけです。
　つまり、１つのボタンで、
　マクロをスタートさせたり、ストップさせたりする方法の紹介になります。
　ただし、1/100秒、つまり、ミリ秒単位で計測できるようにします。

ストップウォッチVBAコード


　
Private blnStop As Boolean
　Private blnStart As Boolean
　Sub StopWatch()
　　　Dim dblTimer As Double
　　　If blnStart = True Then
　　　　　blnStop = True
　　　　　Exit Sub
　　　End If
　　　blnStart = True
　　　blnStop = False
　　　dblTimer = Timer
　　　Do Until blnStop = True
　　　　　Cells(1, 1) = Int((Timer - dblTimer) * 100) / 100
　　　　　DoEvents
　　　Loop
　　　blnStart = False
　　　blnStop = False
　End Sub

ストップウォッチVBA解説

上記マクロVBAを標準モジュールに登録し、
　そのマクロを登録したボタンを、シートに追加して下さい。
　時間表示は、"A1"セルにしてあります。
　A1セルは、
　・フォントサイズを大きく
　・背景色とフォント色を設定
　・表示形式を少数点以下2桁
　このように設定しておくと、ストップウォッチらしく見えると思います。
　 まず、上記のように、モジュールレベル変数を定義します。
　blnStartは、スタートしている間、Trueにします。
　blnStopは、ストップさせる時に、Trueにします。
　この２つの変数で、動きを制御している訳です。
　 注意点
　マクロ実行中に、ボタン押下を可能とする為、
　ScreenUpdatingをFalseにはしない事です。
　そして、
　 DoEvents を入れる事になります。
　DoEventsが無いと、直ぐには停止しません。
　エクセルでマクロVBAを書いてストップウォッチそのものを作る事はあまりないと思います。
　ここでは、ストップウオッチを作るテクニックを紹介する事で、
　そのテクニックが、他で応用出来るだろうと言う事です。
　この方法は、時間のかかるマクロを途中で停止させたい場合に有効です。
　試してみて下さい。

ストップウォッチ機能強化版

マクロVBAの一つのテクニックとして紹介したストップウォッチVBAですが、
　意外に反応が多く、問合せをいただくこともあり、
　その中の話として、
　・ラップタイム（区間の時間）
　・スプリットタイム（その時点までの時間）
　これらを計測したいとの要望をいただきました。
　そこで、これらの機能を追加した機能強化版を作成しました。
　 ストップウォッチ改（1/100秒）（Timer）
　ストップウォッチを作る時の、基本的なVBAコードを以前に公開しましたが、時々お問い合わせをいただくことがあり、それなりに重宝されている ようです。そこで、もう少し機能強化したものを作成した次第です。公開済みのストップウォッチ ストップウォッチ（1/100秒）（Timer） 追加する機能 ・ラップタイム（区間の時間） ・スプリットタイム（その時点までの時間）…

重複の無いユニークなデータ作成

　簡単な例で
　シート「元データ」
　A列に、１行目に見出し、２行目以降にデータが入っている
　シート「ユニーク」
　このA列に、シート「元データ」のA列をユニーク（一意）にして取り出します。
　まずは、エクセルらしく、ワークシート関数とフィルターを使って
　
Sub sample1()
　　　Dim LastRow As Long
　　　With Worksheets("元データ")
　　　　　LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　　.Cells(1, 2) = "作業列"
　　　　　.Range(.Cells(2, 2), .Cells(LastRow, 2)) = "=COUNTIF($A$2:A2,A2)"
　　　　　.Cells(1, 1).AutoFilter Field:=2, Criteria1:=1
　　　　　.Range(.Cells(1, 1), .Cells(LastRow, 1)).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("ユニーク").Cells(1, 1)
　　　　　.Cells(1, 1).AutoFilter
　　　　　.Columns(2).Clear
　　　End With
　End Sub
非常にエクセルらしい、素直な処理です。
　これを使うかは別にして、このマクロは書けるようにしておいた方が良いでしょう。
　では、イヤだ、自力で全部やりたいって人には
　
Sub sample2()
　　　Dim LastRow As Long
　　　With Worksheets("元データ")
　　　　　LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　　Worksheets("ユニーク").Cells(1, 1) = .Cells(1, 1)
　　　　　Call sample2sub(.Range(.Cells(2, 1), .Cells(LastRow, 1)), Worksheets("ユニーク").Cells(2, 1))
　　　End With
　End Sub
　Sub sample2sub(MyRange As Range, Target As Range)
　　　Dim i As Long
　　　Dim blnFind As Boolean
　　　Dim MyArray
　　　Dim MyCell As Range
　　　For Each MyCell In MyRange
　　　　　If Not IsArray(MyArray) Then
　　　　　　　ReDim MyArray(1 To 1, 1 To 1)
　　　　　　　MyArray(1, UBound(MyArray, 2)) = MyCell
　　　　　Else
　　　　　　　blnFind = False
　　　　　　　For i = LBound(MyArray, 2) To UBound(MyArray, 2)
　　　　　　　　　If MyArray(1, i) = MyCell Then
　　　　　　　　　　　blnFind = True
　　　　　　　　　　　Exit For
　　　　　　　　　End If
　　　　　　　Next i
　　　　　　　If blnFind = False Then
　　　　　　　　　ReDim Preserve MyArray(1 To 1, 1 To UBound(MyArray, 2) + 1)
　　　　　　　　　MyArray(1, UBound(MyArray, 2)) = MyCell
　　　　　　　End If
　　　　　End If
　　　Next
　　　Target.Resize(UBound(MyArray, 2), 1) = WorksheetFunction.Transpose(MyArray)
　End Sub
ふふ、どうだ！！！
　これが、さらーと書けるようなら、私のブログは、もう二度と見るなって事で（笑）
　でも、これだと、
　sample2sub
　これは汎用性があるので、どこでも使えますね。
　もうちょっとなんとかならないかって人には
　
Sub sample3()
　　　Dim LastRow As Long
　　　With Worksheets("元データ")
　　　　　LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
　　　　　.Range(.Cells(1, 1), .Cells(LastRow, 1)).AdvancedFilter _
　　　　　　　Action:=xlFilterCopy, _
　　　　　　　CopyToRange:=Worksheets("ユニーク").Cells(1, 1), _
　　　　　　　Unique:=True
　　　End With
　End Sub
まあ、一番簡単ですよね。
　ただ、
　「フィルタオプションの設定」
　これを使える人じゃないと、お勧めできないです。
　これ以外にも、いろいろやり方はいっぱいありますが、
　腕試しに、いろいろ挑戦してみるには、良い題材だと思います。
　では、挑戦してみて下さい。

棒グラフ・折れ線グラフのサンプルマクロ

　グラフはプロパティ・メソッドも多いので、自分の覚書もかねて掲載しました。
　 この元データから、以下のグラフが作成されます。
　 解説は、プログラム内のコメントを参考にして下さい。
　
Sub sample1()
　　　Dim i As Integer '系列のFor～Nextで使用
　　　Dim rowMax As Long 'グラフ範囲の最終行
　　　Dim colMax As Long 'グラフ範囲の最終列
　　　Dim MyRange As Range 'グラフ範囲
　　　Dim chartObj As ChartObject 'Chartオブジェクトのコンテナ
　　　rowMax = Cells(Rows.Count, 1).End(xlUp).Row 'グラフ範囲の最終行
　　　colMax = Cells(2, Columns.Count).End(xlToLeft).Column 'グラフ範囲の最終列
　　　Set MyRange = Range(Cells(1, 1), Cells(rowMax, colMax)) 'グラフ範囲
　 'Chartを追加、グラフ範囲の右隣に、グラフ範囲の倍の大きさで作成
　　　Set chartObj = ActiveSheet.ChartObjects.Add(MyRange.Width, MyRange.Top, MyRange.Width * 2, MyRange.Height * 2)
　 '追加されたChartオブジェクトに対する処理
　　　With chartObj.Chart
　 '元データ範囲の設定
　　　　　.SetSourceData MyRange
　 'タイトル表示
　　　　　.HasTitle = True
　　　　　.ChartTitle.Text = "=" & MyRange.Cells(1, 1).Address(ReferenceStyle:=xlR1C1, External:=True)
　 '全系列に対する処理
　　　　　For i = 1 To .SeriesCollection.Count
　　　　　　　With .SeriesCollection(i)
　　　　　　　　　Select Case i
　　　　　　　　　　　Case 1, 3 '売上金額
　　　　　　　　　　　　　.ChartType = xlColumnClustered '縦棒グラフ
　　　　　　　　　　　　　.AxisGroup = 1 '主軸
　　　　　　　　　　　　　.ApplyDataLabels 'データラベル表示
　　　　　　　　　　　　　.DataLabels.NumberFormatLocal = "#,##," 'データラベルの表示形式
　　　　　　　　　　　　　.Interior.Color = Cells(2, i + 1).Interior.Color '棒グラフの色
　　　　　　　　　　　Case 2, 4 '昨年比
　　　　　　　　　　　　　.ChartType = xlLine '折れ線グラフ
　　　　　　　　　　　　　.AxisGroup = 2 '第2軸
　　　　　　　　　　　　　.Border.Color = Cells(2, i + 1).Interior.Color '折れ線グラフの色
　　　　　　　　　End Select
　　　　　　　End With
　　　　　Next
　 '主軸の書式設定
　　　　　.Axes(xlValue).TickLabels.NumberFormatLocal = "#,###," '表示形式
　 '第2軸の書式設定
　　　　　.Axes(xlValue, xlSecondary).MinimumScale = 0.8 '最小値
　　　　　.Axes(xlValue, xlSecondary).MaximumScale = 1.2 '最大値
　　　　　.Axes(xlValue, xlSecondary).MajorUnit = 0.05 '目盛間隔
　　　　　.Axes(xlValue, xlSecondary).TickLabels.NumberFormatLocal = "0%" '表示形式
　　　End With
　End Sub
系列データのデータ数が増えた時に、データ範囲を変更するマクロも掲載しておきます。
　グラフに設定済の範囲を自動拡張するように書いています。
　
Sub sample2()
　　　Dim i As Long '系列のFor～Nextで使用
　　　Dim rowMin As Long 'グラフデータ範囲の開始行
　　　Dim rowMax As Long 'グラフデータ範囲の最終行
　　　Dim strFormula As String 'グラフデータ範囲の設定文字列
　　　Dim strExternal() As String 'グラフのSERIES関数の引数毎に分割した文字列
　　　Dim strAddress() As String 'ADDRESS文字列をシートとRANGE指定に分割した文字列
　　　Dim newAddress1 As String 'SERIES関数の新しい系列名のADDRESS
　　　Dim newAddress2 As String 'SERIES関数の新しい系列値のADDRESS
　 'Chartオブジェクトに対する処理
　　　With ActiveSheet.ChartObjects(1).Chart
　 '全系列に対する処理
　　　　　For i = 1 To .SeriesCollection.Count
　 'グラフデータ範囲の設定文字列
　　　　　　　strFormula = .SeriesCollection(i).Formula
　 '=SERIES(引数・・・)を引数だけにする
　　　　　　　strFormula = Replace(Replace(strFormula, "=SERIES(", ""), ")", "")
　 'SERIES関数の引数毎に分割
　　　　　　　strExternal = Split(strFormula, ",")
　 '系列名（SERIES関数の第2引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(1), "[" & ThisWorkbook.Name & "]", ""), "!")
　 '系列名の開始行
　　　　　　　rowMin = Worksheets(strAddress(0)).Range(strAddress(1)).Item(1).Row
　 '系列名の最終行
　　　　　　　rowMax = Worksheets(strAddress(0).Cells(Rows.Count, Worksheets(strAddress(0)).Range(strAddress(1)).Item(1).Column).End(xlUp).Row
　 'SERIES関数の新しい系列名のADDRESS
　　　　　　　newAddress1 = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1).Address(External:=True)
　 '系列値（SERIES関数の第3引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(2), "[" & ThisWorkbook.Name & "]", ""), "!")
　 'SERIES関数の新しい系列値のADDRESS
　　　　　　　newAddress2 = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1).Address(External:=True)
　 'グラフデータ範囲の再設定
　　　　　　　.SeriesCollection(i).Formula = "=SERIES(" & _
　　　　　　　　　　　　　　　　　　　　　　　strExternal(0) & "," & _
　　　　　　　　　　　　　　　　　　　　　　　newAddress1 & "," & _
　　　　　　　　　　　　　　　　　　　　　　　newAddress2 & "," & _
　　　　　　　　　　　　　　　　　　　　　　　i & ")"
　　　　　Next i
　　　End With
　End Sub
以上２つのマクロを応用すれば、
　棒グラフ・折れ線グラフなら、大抵は何とかなるでしょう。

WEBデータの取得方法

　WEBページのデータを取得して、エクセルのデータとして取り込みたいとの要望が多いようです。
　マクロVBAでWEBページのデータを取得する方法はいろいろあります。
　 QueryTables
　InternetExplorer
　MSHTML
　MSXML2
　順番に、以下で説明します。

サンプルページ

まず、サンプルページとして、ヤフーファイナンスの、以下のページを使います。
　 http://info.finance.yahoo.co.jp/ranking/?kd=1&mk=1&tm=d&vl=a
　このページの一覧表の部分をエクセルに取り込みます。
　このページは、ランキングですので、複数ページあります。
　上のURLは、最初のページです。
　では２ページ目はと言うと、
　 http://info.finance.yahoo.co.jp/ranking/?kd=1&tm=d&vl=a&mk=1& p=2
　このようなURLになります。
　この場合、最期の p=2 がページ数になっています。
　これを変更すれば、各ページが取得できます。
　 p=1 なら、最初のページも取得可能です。
　従って、以降のマクロでは
　 http://info.finance.yahoo.co.jp/ranking/?kd=1&tm=d&vl=a&mk=1&p=1
　として取得しています。
　この数値を順次変更して取得すれば、複数ページの取得も可能です。
　ただし、このページは近年アクセス方法に制限が書けられています。
　そこで、制限のない当サイトの祝日一覧のページもサンプルとして使います。

QueryTables

まずは、
　 エクセル本来の機能で、Webクエリです。
　
Sub sample1()
　　　With ActiveSheet.QueryTables.Add(Connection:= _
　　　　　"URL;http://info.finance.yahoo.co.jp/ranking/?kd=1&tm=d&vl=a&mk=1&p=1", _
　　　　　Destination:=Range("$A$1"))
　　　　　.Name = "?kd=1&tm=d&vl=a&mk=1&p=1"
　　　　　.FieldNames = True
　　　　　.RowNumbers = False
　　　　　.FillAdjacentFormulas = False
　　　　　.PreserveFormatting = True
　　　　　.RefreshOnFileOpen = False
　　　　　.BackgroundQuery = True
　　　　　.RefreshStyle = xlInsertDeleteCells
　　　　　.SavePassword = False
　　　　　.SaveData = True
　　　　　.AdjustColumnWidth = True
　　　　　.RefreshPeriod = 0
　 .WebSelectionType = xlAllTables
　　　　　.WebFormatting = xlWebFormattingNone
　　　　　.WebPreFormattedTextToColumns = True
　　　　　.WebConsecutiveDelimitersAsOne = True
　　　　　.WebSingleBlockTextImport = False
　　　　　.WebDisableDateRecognition = False
　　　　　.WebDisableRedirections = False
　　　　　.Refresh BackgroundQuery:=False
　　　End With
　End Sub
太字の xlAllTables の指定で、tableのみ取得しています。
　これで済む場合は、これが最も簡単です。
　マクロの記録を使えば、そのまま使えます。
　上記も、マクロの記録のままです。

InternetExplorer

次は、
　 InternetExplorerを、VBAから操作します。
　
Sub sample2()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim objITEM As Object
　　　Dim objIE As New InternetExplorer
　　　objIE.Visible = False
　　　objIE.Navigate "http://info.finance.yahoo.co.jp/ranking/?kd=1&tm=d&vl=a&mk=1&p=1"
　　　Call untilReady(objIE)
　　　Range("A1").CurrentRegion.Offset(1, 0).ClearContents
　　　i = 2
　　　j = 1
　　　For Each objITEM In objIE.Document.getElementsByTagName("td")
　　　　　Cells(i, j) = objITEM.innerText
　　　　　j = j + 1
　　　　　If j > 10 Then
　　　　　　　j = 1
　　　　　　　i = i + 1
　　　　　End If
　　　Next
　　　objIE.Quit
　　　Set objITEM = Nothing
　　　Set objIE = Nothing
　End Sub
　Sub untilReady(objIE As Object, Optional ByVal WaitTime As Integer = 10)
　　　Dim starttime As Date
　　　starttime = Now()
　　　Do While objIE.Busy = True Or objIE.ReadyState <> READYSTATE_COMPLETE
　　　　　DoEvents
　　　　　If Now() > DateAdd("S", WaitTime, starttime) Then
　　　　　　　Exit Do
　　　　　End If
　　　Loop
　　　DoEvents
　End Sub
※「Microsoft Internet Control」を参照設定して下さい。
　問題は、HTMLを取得後の解析になります。
　For Each objITEM In objIE.Document.getElementsByTagName("td")
　Tableのtrの中のtdで、必要なデータのみ取得しています。
　これについては、VBAの知識ではなく、HTMLの知識が必要になります。
　Table、tr、td等が分からない場合は、HTMLの勉強をして頂く必要があります。
　ここでは、HTMLの解説は省略します。
　 ※注意
　untilReady内のループでは、本来なら、Sleepさせた方が良いのですが、
　APIの使用になるので、ここでは省略しています。
　Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
　を先頭に記述し、
　ループ内で、適宜、
　Sleep 100
　程度を入れておくと良いでしょう。

MSHTML

さらに、
　 MSHTML.HTMLDocumentを使った方法です。
　
Sub sample3()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim objXML As New MSHTML.HTMLDocument
　　　Dim htmlDoc As New MSHTML.HTMLDocument
　　　Dim objITEM As Object
　　　Set htmlDoc = objXML.createDocumentFromUrl("https://excel-ubara.com/EXCEL/EXCEL910.html", vbNullString)
　　　Call untilReady(htmlDoc)
　　　Range("A1").CurrentRegion.Offset(1, 0).ClearContents
　　　i = 2
　　　j = 1
　　　For Each objITEM In htmlDoc.getElementsByTagName("td")
　　　　　Cells(i, j) = objITEM.innerText
　　　　　j = j + 1
　　　　　If j > 3 Then
　　　　　　　j = 1
　　　　　　　i = i + 1
　　　　　End If
　　　Next
　　　Set objITEM = Nothing
　　　Set htmlDoc = Nothing
　　　Set objXML = Nothing
　End Sub
　Sub untilReady(htmlDoc As MSHTML.HTMLDocument, Optional ByVal WaitTime As Integer = 10)
　　　Dim starttime As Date
　　　starttime = Now()
　　　Do Until htmlDoc.ReadyState = "complete"
　　　　　DoEvents
　　　　　If Now() > DateAdd("S", WaitTime, starttime) Then
　　　　　　　Exit Do
　　　　　End If
　　　Loop
　　　DoEvents
　End Sub
※「Microsoft HTML Object Library」を参照設定して下さい。
　先のヤフーファイナンスでは、この方法ではアクセスできなくなっています。
　以前は、この方法でも取得できたのですが、近年はいろいろ制限のあるページが増えてきたようです。
　そこで、当サイトの祝日一覧のページを取得するようにしています。
　InternetExplorerの部分がMSHTML.HTMLDocumentになった程度で、
　後は、ほとんど同じです。

MSXML2

さらに、
　 MSXML2.XMLHTTPを使った場合です。
　
Sub sample4()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim objXML As New MSXML2.XMLHTTP
　　　Dim htmlDoc As Object
　　　Set htmlDoc = New MSHTML.HTMLDocument
　　　Dim objITEM As Object
　　　With objXML
　　　　　.Open "GET", "https://excel-ubara.com/EXCEL/EXCEL910.html", False
　　　　　.send (Null)
　　　　　htmlDoc.write .responseText
　　　End With
　　　Range("A1").CurrentRegion.Offset(1, 0).ClearContents
　　　i = 2
　　　j = 1
　　　For Each objITEM In htmlDoc.getElementsByTagName("td")
　　　　　Cells(i, j) = objITEM.innerText
　　　　　j = j + 1
　　　　　If j > 3 Then
　　　　　　　j = 1
　　　　　　　i = i + 1
　　　　　End If
　　　Next
　　　Set objITEM = Nothing
　　　Set htmlDoc = Nothing
　　　Set objXML = Nothing
　End Sub
※「Microsoft XML, v3.0」（v3.0以上を指定して下さい）を参照設定して下さい。
　サンプルとして書いてみましたが、HTMLの解析ができないので、
　結局、MSHTML.HTMLDocumentを使う事になってしまいました。
　また、
　Dim htmlDoc As New MSHTML.HTMLDocument
　としたのでは、
　htmlDoc.writeでエラーになってしまいますので、ちょっと面倒です。
　結果的には、MSHTML.HTMLDocumentの方で良いのではないかという気がします。

WEBデータの取得方法の最後に

番外編としては、Seleniumを使う方法もあります。
　 VBAのスクレイピングを簡単楽にしてくれるSelenium
　VBAでWebスクレイピングする方法としてIE自動操作がありますが、VBA記述が結構面倒になります、もっと簡単にスマートにVBAを書き たいと思ったら…SeleniumBasicを使ってみましょう。SeleniumBasicは、エクセルVBAでのWeb閲覧を自動化することを強力か つ簡単に実現してくれます。
　 VBA+SeleniumBasicで検索順位チェッカー作成
　VBAでSeleniumBasicを使って検索順位チェッカーを作ってみます。SEO対策として各キーワードでの検索順位チェックは欠かせま せんが、簡単に使えてキーワードを大量に指定できる良いツールがなかなかありません。Google検索をスクレイピングすることは、Google利用規約 に反する可能性があります。
　 VBA+SeleniumBasicで検索順位チェッカー（改）
　VBAでSeleniumBasicを使って検索順位チェッカーを作り、Google検索順位の履歴を管理します、既に作成解説した、 VBA+SeleniumBasicで検索順位チェッカー作成こちらの改訂版になります。Google検索をスクレイピングすることは、Google利用 規約に反する可能性があります。
　いずれの方法にしても、
　最初のWebクエリ以外では、HTMLの知識が必要になります。
　ここが書けない場合は、Webクエリでシートに貼り付けた後で、
　シート内のデータを解析して、必要なデータだけに編集する等が良いでしょう。

右クリックメニューの変更（CommandBars）

　セルを右クリックした時のショートカットメニューを変更します、
　右クリックメニューからマクロを起動できるようにすることで利便性が向上します・
　 シートモジュール に以下を追加します。
　
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
　　　Dim cmdBra1 As CommandBarControl
　　　Dim cmdBra2 As CommandBarControl
　 '標準状態にリセット
　　　Application.CommandBars("Cell").Reset
　 '全てのメニューを一旦削除
　　　For Each cmdBra1 In Application.CommandBars("Cell").Controls
　　　　　cmdBra1.Visible = False
　　　Next
　 '以下で、新規のメニューを追加
　　　Set cmdBra1 = Application.CommandBars("Cell").Controls.Add()
　　　With cmdBra1
　　　　　.Caption = "AA"
　　　　　.FaceId = 2
　　　　　.OnAction = "AA"
　　　End With
　　　Set cmdBra1 = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup)
　　　With cmdBra1
　　　　　.Caption = "BB"
　　　End With
　　　Set cmdBra2 = cmdBra1.Controls.Add()
　　　With cmdBra2
　　　　　.Caption = "BB1"
　　　　　.FaceId = 3
　　　　　.OnAction = "BB1"
　　　End With
　　　Set cmdBra2 = cmdBra1.Controls.Add()
　　　With cmdBra2
　　　　　.Caption = "BB2"
　　　　　.FaceId = 4
　　　　　.OnAction = "BB2"
　　　End With
　　　Application.CommandBars("Cell").ShowPopup
　　　Application.CommandBars("Cell").Reset
　　　Cancel = True
　End Sub
標準モジュール に以下を追加
　
Sub AA()
　　　ActiveCell.Value = "AA"
　End Sub
　Sub BB1()
　　　ActiveCell.Value = "BB1"
　End Sub
　Sub BB2()
　　　ActiveCell.Value = "BB2"
　End Sub
OnActionで呼ぶプロシージャーは、必ず標準モジュールに作成します。
　ここでは、単にアクティブセルに文字を入れているだけです。
　これで、シートモジュールを追加したシートでセルを右クリックすると
　 このように表示され、メニューをクリックすると、対応する文字がセルに入るようになります。
　 コマンドバー.Controls.Add()
　Addに指定する引数です。
　
名前 説明
Type 指定したコマンド バーに追加するコントロールの種類を指定します。使用できる定数は、MsoControl クラスの msoControlButton、msoControlEdit、msoControlDropdown、msoControlComboBox、 msoControlPopup のいずれかです。
Id 組み込みのコントロールを表す整数を指定します。この引数を 1 に設定するか省略すると、指定した種類の空白のカスタム コントロールがコマンド バーに追加されます。
Parameter 組み込みのコントロールの場合、この引数はコンテナー アプリケーションでコマンドを実行するときに使用されます。カスタム コントロールの場合、この引数を使用して、Visual Basic のプロシージャに情報を渡したり、Tag プロパティの 2 番目の値のようなコントロールの情報を格納することができます。
Before コマンド バーにおける新しいコントロールの位置を表す数字を指定します。新しいコントロールは、指定した位置にあるコントロールの直前に挿入されます。この引数を省略すると、コントロールは指定したコマンド バーの末尾に追加されます。
Temporary True を指定すると、新しいコントロールが一時的なものになります。このコントロールは、コンテナー アプリケーションの終了と同時に自動的に削除されます。この引数を省略すると、既定値の False になります。
上記サンプルでは、"BB"は親メニューになりますので、
　 Type:=msoControlPopup
　これを指定しています。
　他で省略している場合は、
　 Type:=msoControlButton
　となります。
　 コントロールのメンバーについて
　Type:=msoControlButtonの場合には、アイコンを指定できます。
　それが、 FaceId です。
　この番号と実際のアイコンについては、「 エクセルのアイコン取得 」を参照して下さい。
　エクセル内のアイコンを取得します。「右クリックメニューの変更」のFaceIdとして使用します。2003までなら、ツールバーが追加されま す。2007以降では、リボンのアドインの中に追加されます。ConststartNoAsInteger=1'開始番号を指定 ConststopNoAsInteger=50'終了番号を指定 この数値を変更して実行して下さい。
　Type毎に、属するメンバー（メソッド、プロパティ）が少しずつ違いますので、詳細はヘルプ等を参照して下さい。

エクセルのアイコン取得（FaceID）

　エクセル内のアイコンを取得します。
　「 右クリックメニューの変更 」のFaceIdとして使用します。
　
Sub sample()
　　　Const startNo As Integer = 1 '開始番号を指定
　　　Const stopNo As Integer = 50 '終了番号を指定
　　　Dim cmdBar As CommandBar
　　　Dim cmdBarCtl As CommandBarControl
　　　Dim i As Integer
　　　On Error Resume Next
　　　Set cmdBar = Application.CommandBars("FaceId")
　　　If cmdBar Is Nothing Then
　　　　　Set cmdBar = Application.CommandBars.Add(Name:="FaceId", Temporary:=True)
　　　　　For i = startNo To stopNo
　　　　　　　Set cmdBarCtl = cmdBar.Controls.Add(Type:=msoControlButton)
　　　　　　　With cmdBarCtl
　　　　　　　　　.FaceID = i
　　　　　　　　　.TooltipText = i
　　　　　　　End With
　　　　　Next
　　　　　cmdBar.Visible = True
　　　Else
　　　　　For i = startNo To stopNo
　　　　　　　With cmdBar.Controls(i - startNo + 1)
　　　　　　　　　.FaceID = i
　　　　　　　　　.TooltipText = i
　　　　　　　End With
　　　　　Next
　　　End If
　　　Set cmdBarCtl = Nothing
　　　Set cmdBar = Nothing
　End Sub
2003までなら、ツールバーが追加されます。
　2007以降では、リボンのアドインの中に追加されます。
　Const startNo As Integer = 1 '開始番号を指定
　Const stopNo As Integer = 50 '終了番号を指定
　この数値を変更して実行して下さい。
　50以上の範囲を指定すると、画面に収まらないので、50ずつ実行してみて下さい。
　途中、割り当てのないIDもかなりありますが、4000以上のIDにも入っています。
　目的のアイコンがあるなら、ちょっと面倒ですが探してみて下さい。

人口ピラミッドのグラフをマクロで作成

　人口ピラミッドのグラフ作成は、設定項目が多く、かなり面倒です。
　マクロでサクッと作って、細かい部分を手動で設定できれば楽です。
　 この表から、以下のグラフを作成します。
　 手動で設定すると、かなり多くの手順が必要になります。
　以下のマクロを実行すると、サクッと作られます。
　
Sub チャート作成()
　　　Dim ws As Worksheet '対象シート
　　　Dim MyRange As Range 'グラフ範囲
　　　Dim chartObj As ChartObject 'Chartオブジェクトのコンテナ
　　　Set ws = ActiveSheet
　　　Set MyRange = ws.Range(" A1 ").CurrentRegion 'グラフ範囲
　 'Chartを追加、グラフ範囲の右隣に、グラフ範囲の3倍の大きさで作成
　　　Set chartObj = ws.ChartObjects.Add(MyRange.Width + MyRange.Left, MyRange.Top, MyRange.Width * 3, MyRange.Height * 1)
　 '追加されたChartオブジェクトに対する処理
　　　With chartObj.Chart
　 '元データ範囲の設定
　　　　　.SetSourceData MyRange
　 '横棒グラフ
　　　　　.ChartType = xlBarClustered
　 '系列に対する処理
　　　　　With .SeriesCollection(1)
　　　　　　　.Interior.Color = vbBlue 'グラフの色
　　　　　End With
　　　　　With .SeriesCollection(2)
　　　　　　　.AxisGroup = 2 '第2軸
　　　　　　　.Interior.Color = vbRed 'グラフの色
　　　　　End With
　 '主軸の書式設定
　　　　　With .Axes(xlValue)
　　　　　　　.TickLabels.NumberFormatLocal = "#,###;" '表示形式
　　　　　　　.MinimumScale = -60 0 '最小値
　　　　　　　.MaximumScale = 500 '最大値
　　　　　　　.MajorUnit = 100 '目盛間隔
　　　　　　　.ReversePlotOrder = True '反転する
　　　　　End With
　 '主軸の幅
　　　　　With .ChartGroups(1)
　　　　　　　.Overlap = 90
　　　　　　　.GapWidth = 10
　　　　　End With
　 '第2軸の書式設定
　　　　　With .Axes(xlValue, xlSecondary)
　　　　　　　.TickLabels.NumberFormatLocal = "#,###;" '表示形式
　　　　　　　.MinimumScale = -600 '最小値
　　　　　　　.MaximumScale = 500 '最大値
　　　　　　　.MajorUnit = 100 '目盛間隔
　　　　　　　.ReversePlotOrder = False '反転しない
　　　　　End With
　 '第2軸の幅
　　　　　With .ChartGroups(2)
　　　　　　　.Overlap = 90
　　　　　　　.GapWidth = 10
　　　　　End With
　 '縦軸の書式設定
　　　　　.Axes(xlCategory).TickLabels.Offset = 0
　　　　　.Axes(xlCategory).MajorTickMark = xlNone
　 '凡例
　　　　　With .Legend
　　　　　　　.Left = 0
　　　　　　　.Width = 75
　　　　　　　.Height = 25
　　　　　　　.Left = (chartObj.Chart.ChartArea.Width - .Width) / 2
　　　　　　　.Top = chartObj.Chart.ChartArea.Height - .Height
　　　　　End With
　 'プロットエリア
　　　　　With .PlotArea
　　　　　　　.Left = 0 '左には自動で最小の余白が付く
　　　　　　　.Width = chartObj.Width '左右に自動で最小の余白が付く
　　　　　End With
　　　End With
　End Sub
太字の部分は適宜修正してお使い下さい。
　特に、最大値・最小値は、データに合わせて変更が必要です。
　棒グラフの3D化は今回は組み込んでいません。
　細かいレイアウトは手動でも問題ないでしょう。

写真の取込方法について（Pictures.Insert,Shapes.AddPicture）

　写真を取り込んで、アルバムのようにしたり、
　各種の資料を作ったりと、写真をエクセルに取り込む機会は多いようです。
　しかし、最近は写真のサイズも大きくなり、
　手動で取り込んだままではスクロールもままならない状態となってしまいます。
　そこで、写真ファイルを指定し、A列に上から順番に貼り付け、
　さらにセル内に収まるように縮小するマクロになります。
　まずは、マクロの記録でも使われている
　 Pictures.Insert
　を使って
　
Sub sample1()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim FileName As Variant
　　　Dim dblScal As Double
　　　Dim sp As Shape
　　　FileName = Application.GetOpenFilename( _
　　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
　　　　　MultiSelect:=True)
　　　If Not IsArray(FileName) Then
　　　　　Exit Sub
　　　End If
　　　For Each sp In ActiveSheet.Shapes
　　　　　If sp.TopLeftCell.Column = 1 Then
　　　　　　　sp.Delete
　　　　　End If
　　　Next
　　　j = 1
　　　For i = LBound(FileName) To UBound(FileName)
　　　　　Cells(j, 1).Select
　　　　　With ActiveSheet.Pictures.Insert(FileName(i))
　 'サイズ調整、セル内に収める
　　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)
　　　　　　　Else
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)
　　　　　　　End If
　　　　　　　.Width = .Width * dblScal '縦横比を維持して縮小される
　　　　　End With
　　　　　j = j + 1
　　　Next i
　End Sub
これで、とりあえず、ちゃんと貼りつきました。
　しかし、元ファイルが、取り込んだ時のフォルダーに存在しないと表示できません。
　これは不都合です。
　エクセルファイルを配布できません。
　以下では、写真をリンクではなくエクセルに貼り付けています。
　 Shapes.AddPicture
　を使ってリンクせずに取込
　
Sub sample2()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim FileName As Variant
　　　Dim dblScal As Double
　　　Dim sp As Shape
　　　FileName = Application.GetOpenFilename( _
　　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
　　　　　MultiSelect:=True)
　　　If Not IsArray(FileName) Then
　　　　　Exit Sub
　　　End If
　　　For Each sp In ActiveSheet.Shapes
　　　　　If sp.TopLeftCell.Column = 1 Then
　　　　　　　sp.Delete
　　　　　End If
　　　Next
　　　j = 1
　　　For i = LBound(FileName) To UBound(FileName)
　　　　　Cells(j, 1).Select
　　　　　With ActiveSheet.Shapes.AddPicture( _
　　　　　　　　　FileName:=FileName(i), _
　　　　　　　　　LinkToFile:=False, _
　 SaveWithDocument:=True , _
　　　　　　　　　Left:=Selection.Left, _
　　　　　　　　　Top:=Selection.Top, _
　　　　　　　　　Width:= 0 , _
　　　　　　　　　Height:= 0 )
　 '一旦、元のサイズに戻す
　　　　　　　.ScaleHeight 1, msoTrue
　　　　　　　.ScaleWidth 1, msoTrue
　 'サイズ調整、セル内に収める
　　　　　　　If Cells(j, 1).Width / .Width < Cells(j, 1).Height / .Height Then
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Width / .Width, 2)
　　　　　　　Else
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(Cells(j, 1).Height / .Height, 2)
　　　　　　　End If
　　　　　　　.Width = .Width * dblScal
　　　　　　　.Height = .Height * dblScal
　　　　　End With
　　　　　j = j + 1
　　　Next i
　End Sub
Shapes.AddPictureでの取込時点では、サイズが不明なので、
　Width:= 0
　Height:= 0 )
　で、サイズ0で取り込んでいます。
　その後、一旦、元のサイズに戻した後に、セル内に収めています。
　写真そのものがエクセルに貼りついていますので、エクセルのサイズは当然大きくなります。

アメブロの記事本文をVBAでバックアップする№1

　 後日追記
　 アメブロの仕様変更が度々あり、ここで紹介しているコードで取得できないものもあります、
　いつ仕様変更されるかわかりませんので、都度変更するのは結構大変です。
　あくまで、WEBページの取得技術方法として参考にしてください。
　アメブロにはバックアップ機能がありません。
　間違って削除・更新してしまう事もありますので、なんとかバックアップを取っておきたいところです。
　ブラウザで記事を表示して、ローカルに保存すれば良いのですが、ちょっと面倒です。
　そして、記事本文以外も全てくっついてきてしまいますので、後々の処置が困ります。
　ExcelマクロVBAを使えば、この記事本文のみのバックアップも可能です。
　VBAで InternetExplorer を操作し、中の情報を取得します。
　ただし、アメブロへのログイン機能は付けていませんので、
　事前に InternetExplorer で アメブロにログイン しておいて下さい。、
　（ログインしたら、InternetExplorerは閉じてしまって良いです）
　まず、以下のようなシートを用意して下さい。
　 色合いは、なんでもかまいません。
　A列には、記事エントリーのIDが入ります。
　IDは数値なのですが、後々の扱いやすさを考慮して、表示形式を「文字列」にして下さい。
　標準モジュールを追加して、
　まずは、以下を貼り付けてください。
　
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
　 ' 64bit 版のExcelの場合は、以下のようにPtrSafeを付けて下さい。
　 'Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
　Sub untilReady(objIE As Object)
　　　Dim starttime As Date
　　　starttime = Now()
　　　Do While objIE.Busy = True Or objIE.ReadyState <> READYSTATE_COMPLETE
　　　　　Sleep 100
　　　　　DoEvents
　　　　　If Now() > DateAdd("S", 10, starttime) Then
　　　　　　　Exit Do
　　　　　End If
　　　Loop
　End Sub
これは、
　InternetExplorerで指定のURLを開いた時に、すべて読み込まれるまで待つためのプロシージャーです。
　InternetExplorerにURLを指定しても、しばらく進捗バーが進むのを待ちますよね、それに相当します。
　 Do While objIE.Busy = True Or objIE.ReadyState <> READYSTATE_COMPLETE
　この部分がそうです。
　 Busy 、または、 COMPLETE 以外の間は待つということです。
　もし応答なしになってしまうと、永久にDo～Loopから抜けませんので、
　 If Now() > DateAdd("S", 10, starttime) Then
　これで、10秒待ってもダメだったら抜けるようにしています。
　では、本題のバックアップするコードに入ります。
　いや、その前に、まずは記事の一覧を取得します。
　 アメブロの記事本文をVBAでバックアップする №1 №2 №3 №4 №5 №6

1次元配列の並べ替え（バブルソート,挿入ソート,クイックソート）

　配列（1次元）の並べ替え方法について、バブルソート、挿入ソート、クイックソートのサンプルになります。
　元来エクセルには、ワークシートの並べ替え機能があります。
　ワークシートにデータを書き出して、ワークシートの並べ替え機能を使えるのですが、
　どうしても、配列をワークシートに途中で書き出すと言うのは面倒なものです。
　そこで、配列を並べ替える必要が出てきます。
　アルゴリズムの解説ではなく、あくまでVBAでの実装サンプルになります。
　ソートアルゴリズムについては、詳細に解説しているサイトをご覧ください。

検証方法

Sheet1 の A1～A10000 にランダムなデータを入れました。
　これを（昇順に）並べ替えて、 Sheet2 に出力 しています。
　
Sub ソート検証()
　　　Dim ws1 As Worksheet
　　　Dim ws2 As Worksheet
　　　Dim myAry1()
　　　Dim myAry2()
　　　Dim i As Long
　　　Set ws1 = Worksheets("Sheet1")
　　　Set ws2 = Worksheets("Sheet2")
　　　myAry1 = ws1.Range("A1:A10000").Value
　 'myAry1は2次元配列なのでmyAry2で1次元配列に変更
　　　ReDim myAry2(LBound(myAry1) To UBound(myAry1))
　　　For i = LBound(myAry1) To UBound(myAry1)
　　　　　myAry2(i) = myAry1(i, 1)
　　　Next
　 '1次元配列ソート
　　　Dim start As Double: start = Timer
　 ' Call バブルソート(myAry2)
　 ' Call 挿入ソート(myAry2)
　 ' Call クイックソート(myAry2, LBound(myAry2), UBound(myAry2))
　　　Debug.Print Timer - start
　 'myAry2は1次元配列なのでmyAry1で2次元配列に変更
　　　For i = LBound(myAry2) To UBound(myAry2)
　　　　　myAry1(i, 1) = myAry2(i)
　　　Next
　　　ws2.Cells.Clear
　　　ws2.Range("A1:A10000").Value = myAry1
　End Sub
ソートごとに、
　 Call バブルソート(myAry2)
　Call 挿入ソート(myAry2)
　 Call クイックソート(myAry2, LBound(myAry2), UBound(myAry2))
　この3行のいずれか1つだけにして実行しています。
　複数回実行し、所要時間の平均時間の概数を記載しています。
　時間はデータとPC環境にかなり依存しますので、あくまで目安になります。

バブルソート

ソートのアルゴリズムの中で、簡単で理解しやすいのは、バブルソートでしょう 。
　バブルは「泡」のことで、並べ替えの過程でデータが下から上（上から下）へ移動する感じが、泡が浮かんでいく様に見えることからこの名前が付いているそうです。
　
Sub バブルソート(ByRef argAry() As Variant)
　　　Dim vSwap As Variant
　　　Dim i As Integer
　　　Dim j As Integer
　　　For i = UBound(argAry) To LBound(argAry) Step -1
　　　　　For j = LBound(argAry) To i - 1
　　　　　　　If argAry(j) > argAry(j + 1) Then
　　　　　　　　　vSwap = argAry(j)
　　　　　　　　　argAry(j) = argAry(j + 1)
　　　　　　　　　argAry(j + 1) = vSwap
　　　　　　　End If
　　　　　Next j
　　　Next i
　End Sub
外側のFor～Nextの１回目が終わった時点で、配列の最後尾に最大値が来ます。
　以下、２回目のループで配列の最後から2番目に2番目に大きいデータが来ます。
　これの繰り返しになっています。
　If argAry(j) > argAry(j + 1) Then
　これを
　If argAry(j) < argAry(j + 1) Then
　とすれば、降順の並べ替えになります。
　非常に単純ですが、処理時間がかかる事が難点です。
　データ件数が、少なければ単純で良いでしょう。
　では、その処理時間を見てみます。
　 １万件で2.7秒 です。
　１万件で2.7秒なら、遅いけど待てない時間ではないでしょうか、それでも件数的には限界でしょうね。
　件数を増やすと、
　 2万件で約13秒 かかってしまいます。
　これはかかりすぎですね、実際に使用するとなると数千件以内に限定されそうです。

挿入ソート

挿入ソート（インサーションソート）は、
　整列してある配列に追加要素を適切な場所に挿入することで並べ替えを行っています。
　アルゴリズムは非常に単純でVBAも簡単です。
　
Sub 挿入ソート(ByRef argAry() As Variant)
　　　Dim Low As Long
　　　Dim Upp As Long
　　　Low = LBound(argAry)
　　　Upp = UBound(argAry)
　　　Dim i As Long, j As Long
　　　Dim vSwap As Variant
　　　For i = Low + 1 To Upp
　　　　　vSwap = argAry(i)
　　　　　For j = i - 1 To Low Step -1
　　　　　　　If argAry(j) > vSwap Then
　　　　　　　　　argAry(j + 1) = argAry(j)
　　　　　　　Else
　　　　　　　　　Exit For
　　　　　　　End If
　　　　　Next
　　　　　argAry(j + 1) = vSwap
　　　Next
　End Sub
基準位置(i)を、それより前の配列の適切な位置に挿入していくことで並べ替えています。
　元の並び順がある程度そろっているときは速いのですが、逆順に並んでいると遅くなります。
　では、その処理時間を見てみます。
　 1万件で約0.81秒
　 2万件で約3.22秒
　ただし、
　バブルソートよりは速そうですが、もし、全く逆順になっているデータの場合、
　 1万件で約1.78秒
　 2万件で約7.18秒
　このように、かなり時間が違ってきます。
　データ順がはっきりしていない場合には、やはり1万件程度までが実質的な使用範囲でしょうか。

クイックソート

さらに、高速なソートアルゴリズムはないのか・・・
　いろいろ沢山あるようですが、その一つとしてクイックソートがあります。
　クイックソートは一般的にかなり高速だといわれてはいますが、
　アルゴリズムとしてはいろいろな亜種があるらしいです。
　ここでは、ごく一般的な方法を採用しています。
　アルゴリズムの詳細は説明が長くなってしまいますので、専門に解説しているページを参照して下さい。
　
Sub クイックソート(ByRef argAry() As Variant, _
　　　　　　　　　　 ByVal lngMin As Long, _
　　　　　　　　　　 ByVal lngMax As Long)
　　　Dim i As Long
　　　Dim j As Long
　　　Dim vBase As Variant
　　　Dim vSwap As Variant
　　　vBase = argAry(Int((lngMin + lngMax) / 2))
　　　i = lngMin
　　　j = lngMax
　　　Do
　　　　　Do While argAry(i) < vBase
　　　　　　　i = i + 1
　　　　　Loop
　　　　　Do While argAry(j) > vBase
　　　　　　　j = j - 1
　　　　　Loop
　　　　　If i >= j Then Exit Do
　　　　　vSwap = argAry(i)
　　　　　argAry(i) = argAry(j)
　　　　　argAry(j) = vSwap
　　　　　i = i + 1
　　　　　j = j - 1
　　　Loop
　　　If (lngMin < i - 1) Then
　　　　　Call クイックソート(argAry, lngMin, i - 1)
　　　End If
　　　If (lngMax > j + 1) Then
　　　　　Call クイックソート(argAry, j + 1, lngMax)
　　　End If
　End Sub
このアルゴリズムをすっきり理解するのは大変ですね。
　基準値を決め、大きい値のグループと小さい値のグループに分けることを繰り返します。
　これを再帰プロージャーで、範囲を狭めながら繰り返しています。
　これにより並べ替えを実現しています。
　では、その処理時間を見てみます。
　 1万件で約0.011秒
　 2万件で約0.022秒
　 10万件で約0.091秒
　 100万件で約1.46秒
　やはり断然はやいですね。
　件数が増えても、実用として問題ない数値だと思います。

最後に

数百件程度の配列なら、バブルソートでもよいですが、
　それ以上になるなら、やはりクイックソートが好ましいでしょう。
　今回の実行例でもそうですが、
　やはり、配列は２次元になる場合が多いです。
　そこで、次回は、
　 ２次元配列の並べ替え
　配列（2次元）の並べ替え方法について、バブルソートとクイックソートのサンプルになります。2次元配列の並べ替えと言えば、まさにワークシー トの並べ替え機能になります。本来は、ワークシートにデータを書き出して、ワークシートの並べ替え機能を使えば良いのですが、しかし、どうしても、配列を ワークシートに処理途中で書き出すと言うのは面倒なものです。

2次元配列の並べ替え（バブルソート,クイックソート）

　配列（2次元）の並べ替え方法について、バブルソートとクイックソートのサンプルになります。
　2次元配列の並べ替えと言えば、まさにワークシートの並べ替え機能になります。
　本来は、ワークシートにデータを書き出して、ワークシートの並べ替え機能を使えば良いのですが、
　しかし、どうしても、配列をワークシートに処理途中で書き出すと言うのは面倒なものです。
　そこで、2次元配列を並べ替える必要が出てきます。
　アルゴリズムの解説ではなく、あくまでVBAでの実装サンプルになります。
　ソートアルゴリズムについては、詳細に解説しているサイトをご覧ください。
　1次元配列の並べ替えについては、以下を参照して下さい。
　 1次元配列の並べ替え（バブルソート,クイックソート）
　配列（1次元）の並べ替え方法について、バブルソート、挿入ソート、クイックソートのサンプルになります。元来エクセルには、ワークシートの並 べ替え機能があります。ワークシートにデータを書き出して、ワークシートの並べ替え機能を使えるのですが、どうしても、配列をワークシートに途中で書き出 すと言うのは面倒なものです。
　VBAコードはほぼ1次元配列と同様になりますが、
　キー位置（インデックス）を指定できるようにしています。

検証方法

Sheet1 の A1～B10000 にランダムなデータを入れました。
　これを（昇順に）並べ替えて、 Sheet2 に出力 しています。
　
Sub ソート検証()
　　　Dim ws1 As Worksheet
　　　Dim ws2 As Worksheet
　　　Dim myAry1()
　　　Dim i As Long
　　　Set ws1 = Worksheets("Sheet1")
　　　Set ws2 = Worksheets("Sheet2")
　　　myAry1 = ws1.Range("A1:B10000").Value
　 '2次元配列ソート
　　　Dim start As Double: start = Timer
　 'Call バブルソート(myAry1, 1)
　 'Call クイックソート(myAry1, LBound(myAry1), UBound(myAry1), 1)
　　　Debug.Print Timer - start
　　　ws2.Cells.Clear
　　　ws2.Range("A1:B10000").Value = myAry1
　End Sub
Call バブルソート(myAry2, 1)
　 Call クイックソート(myAry2, LBound(myAry2), UBound(myAry2), 1)
　引数の最後の,1がキー位置の指定になります。
　この2行のいずれか1つだけにして実行しています。
　複数回実行し、所要時間の平均時間の概数を記載しています。
　時間はデータとPC環境にかなり依存しますので、あくまで目安になります。

バブルソート

ソートのアルゴリズムの中で、簡単で理解しやすいのは、バブルソートでしょう 。
　バブルは「泡」のことで、並べ替えの過程でデータが下から上（上から下）へ移動する感じが、泡が浮かんでいく様に見えることからこの名前が付いているそうです。
　
Sub バブルソート(ByRef argAry() As Variant, ByVal keyPos As Long)
　　　Dim vSwap
　　　Dim i As Integer
　　　Dim j As Integer
　　　Dim k As Integer
　　　For i = LBound(argAry, 1) To UBound(argAry, 1)
　　　　　For j = LBound(argAry) To UBound(argAry) - 1
　　　　　　　If argAry(j, keyPos) > argAry(j + 1, keyPos) Then
　　　　　　　　　For k = LBound(argAry, 2) To UBound(argAry, 2)
　　　　　　　　　　　vSwap = argAry(j, k)
　　　　　　　　　　　argAry(j, k) = argAry(j + 1, k)
　　　　　　　　　　　argAry(j + 1, k) = vSwap
　　　　　　　　　Next
　　　　　　　End If
　　　　　Next j
　　　Next i
　End Sub
外側のFor～Nextの１回目が終わった時点で、配列の最後尾に最大値が来ます。
　以下、２回目のループで配列の最後から2番目に2番目に大きいデータが来ます。
　これの繰り返しになっています。
　If argAry(j, keyPos) > argAry(j + 1, keyPos) Then
　これを
　If argAry(j, keyPos) < argAry(j + 1, keyPos) Then
　とすれば、降順の並べ替えになります。
　KeyPosが、並べ替えのキー位置（インデックス）になります。
　非常に単純ですが、処理時間がかかる事が難点です。
　データ件数が、少なければ単純で良いでしょう。
　では、その処理時間を見てみます。
　私の環境で 約5.34秒 かかりました。
　１万件で5秒以上・・・ちょっと使うにはギリギリですね。
　それでも数千件以内なら、実用として問題ないと思います。

クイックソート

バブルソートよりもっと効率の良いソートアルゴリズムはないのか・・・
　それがクイックソートになります。
　クイックソートは一般的にとても高速だといわれてはいますが、
　アルゴリズムとしてはいろいろな亜種があるらしいです。
　ここでは、ごく一般的な方法を採用しています。
　アルゴリズムの詳細は説明が長くなってしまいますし、上手に解説できませんので、
　専門に解説しているページを参照して下さい。
　
Sub クイックソート(ByRef argAry() As Variant, _
　　　　　　　　 ByVal lngMin As Long, _
　　　　　　　　 ByVal lngMax As Long, _
　　　　　　　　 ByVal keyPos As Long)
　　　Dim i As Long
　　　Dim j As Long
　　　Dim k As Long
　　　Dim vBase As Variant
　　　Dim vSwap As Variant
　　　vBase = argAry(Int((lngMin + lngMax) / 2), keyPos)
　　　i = lngMin
　　　j = lngMax
　　　Do
　　　　　Do While argAry(i, keyPos) < vBase
　　　　　　　i = i + 1
　　　　　Loop
　　　　　Do While argAry(j, keyPos) > vBase
　　　　　　　j = j - 1
　　　　　Loop
　　　　　If i >= j Then Exit Do
　　　　　For k = LBound(argAry, 2) To UBound(argAry, 2)
　　　　　　　vSwap = argAry(i, k)
　　　　　　　argAry(i, k) = argAry(j, k)
　　　　　　　argAry(j, k) = vSwap
　　　　　Next
　　　　　i = i + 1
　　　　　j = j - 1
　　　Loop
　　　If (lngMin < i - 1) Then
　　　　　Call クイックソート(argAry, lngMin, i - 1, keyPos)
　　　End If
　　　If (lngMax > j + 1) Then
　　　　　Call クイックソート(argAry, j + 1, lngMax, keyPos)
　　　End If
　End Sub
このアルゴリズムをすっきり理解するのは大変ですね。
　基準値を決め、大きい値のグループと小さい値のグループに分けることを繰り返します。
　これを再帰プロージャーで、範囲を狭めながら繰り返しています。
　これにより並べ替えを実現しています。
　では、その処理時間を見てみます。
　1万件で 約0.019秒
　 10万件で0.186秒
　やはり断然はやいですね。
　数千件程度の配列なら、バブルソートでも良さそうですが、
　それ以上になるなら、やはりクイックソートを検討したほうが良いでしょう。
　今回は2次元配列として紹介しましたが、
　 ユーザー定義型（構造体）の1次元配列とした方が良い のではないかと思います。
　もちろんデータ内容にもよりますので、構造体にするのが大変な場合は別です。
　ですが、大抵のデータ構造は、構造体を使う事でデータ構造を明示でき、
　かつ、このような並べ替えにおいても、1次元配列として扱えるようになります。
　構造体については、 第110回.ユーザー定義型（構造体）Type
　ユーザー定義型は、名前の通りユーザーが定義できるデータ型になります。普通の変数は、1つの値しか入れられませんが、ユーザー定義型は、複数の異なるデータ型を入れる事が出来ます。プログラミング言語での一般的な呼び方としては、構造体とも呼ばれます。

複数キーでの並べ替えについて

最も簡単な方法が、複数キーを１つに繋げたキーを作成する方法になります。
　キーをつなげて、１つのキーとして扱います。
　この時注意するのは、桁数です。
　Key1 > Key2
　で、数値の場合なら、
　Format(Key1, "00000") & Format(Key1, "00000")
　このように桁数を一致させて結合します。
　もちろん、必要な最大桁数を指定します。
　文字列なら、桁数が揃うように、後ろに半角スペースを入れます。
　Key1 & Space(30 - Len(Key1)) & Key2 & Space(30 - Len(Key2))
　こんな感じです。
　これをソートキーとすることで複数キーの並べ替えが可能です。

ワークシートを使って並べ替え・・・番外編

最期に、ワークシートを使って2次元配列を並べ替えするプロシージャーを紹介します。
　Excel.Applicationのインスタンツを作成し、非表示Excel内で並べ替えを行います。
　
Sub SheetSort(ByRef argAry() As Variant, ByVal keyPos As Long)
　　　Dim wb As Workbook
　　　Dim ws As Worksheet
　　　Dim rng As Range
　 Dim xlApp As New Excel.Application
　 Set wb = xlApp.Workbooks.Add
　　　Set ws = wb.ActiveSheet
　　　With ws
　　　　　Set rng = .Range(.Cells(LBound(argAry, 1), LBound(argAry, 2)), .Cells(UBound(argAry, 1), UBound(argAry, 2)))
　　　　　rng.Value = argAry
　 rng.Sort Key1:=.Cells(1, keyPos), Order1:=xlAscending, Header:=xlNo
　　　　　argAry = rng.Value
　　　End With
　 wb.Close SaveChanges:=False
　 Set xlApp = Nothing
　End Sub
上記は、 LBoundが1 であることを前提にしています。
　 LBoundが0の場合は、1を足し引きする 部分の追加が必要になります。
　では、使い方です。
　
Sub test3()
　　　Dim ws1 As Worksheet
　　　Dim ws2 As Worksheet
　　　Dim myAry1()
　　　Dim i As Long
　　　Set ws1 = Worksheets("Sheet1")
　　　Set ws2 = Worksheets("Sheet2")
　　　myAry1 = ws1.Range("A1:B10000").Value
　 'シートでソート
　　　Dim start As Double: start = Timer
　　　Call SheetSort(myAry1, 2)
　　　Debug.Print Timer - start
　　　ws2.Cells.Clear
　　　ws2.Range("A1:C10000") = myAry1
　End Sub
1万件で約1.398秒
　 10万件で6.13秒
　Excelインスタンスを生成し、ブックの追加をしている事を考えれば、
　予想以上に速いですね。
　このくらいの件数までなら問題ないのではないでしょうか。
　今回の時間だけを見るとクイックソートの方が断然早いのですが、
　シート利用の場合は、並べ替え以外の時間がほとんどになっています。
　ワークシートの並べ替えは非常に高速に動作しています。
　従って、作業中のワークシートで並べ替えが可能ならば、それが最も良いと言う事になります。
　少なくとも、配列を作成前がシートであったりソート後にシートに出力するのであれば、
　シートで並べ替えしたほうが間違いなく良いでしょう。

数独（ナンプレ）を解くVBAに挑戦№1

　数独は、一般に「ナンバープレース（ナンプレ）」と呼ばれ、外国では「 sudoku 」と呼ばれているようです、
　この数独をExcelマクロVBAで解いてみようと言う事です。
　解き方は、とにかく片っ端から数字を当てはめていくという、なんとも芸の無い方法です。（笑）
　作ってみようと思い立ったのですが、そもそも数独はあまりやったことが無く、
　効率的な解き方とかは、私は知らないので、手当たり次第に数値を当てはめていけば何とかなるだろうと・・・
　とりあえず何とかなりましたので、掲載します。
　 数独のルール
　・空いているマスに1～9のいずれかの数字を入れる。
　・縦、横の各列及び、太線で囲まれた3×3のブロック内に同じ数字が複数入ってはいけない。
　非常に単純なルールなので、プログラム練習には向いていますね。
　 このようなシートを用意します。
　 問題は、適当に探して下さい。
　上記は、ネットで適当に探しました。
　もし、著作権みたいなものがあるならゴメンナサイ。
　 実行結果
　VBAを実行すると、以下のように回答がでます。
　 途中結果をセルに表示しなければ、
　 約1秒 程度で回答がでます。
　途中結果をセルに表示すると、かなり時間がかかります。
　それだけ、試行錯誤の繰り返しだと言う事です。
　でも、途中結果をセルに表示して、のんびり見ていると、
　PCが試行錯誤している様が確認できて、結構楽しいです。
　次回は、解法の具体的なアルゴリズムをもう少し掘り下げます。
　 №2へ続きます。
　数独（ナンプレ）を解くVBAに挑戦 №1 №2 №3 №4 №5
　※ 数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証
　数独（ナンプレ）を解くアルゴリズムを例に、アルゴリズムの要点と、それによるパフォーマンスを検証します、数独（ナンプレ）を解くVBAに挑 戦 ここでは、とにかく全ての数字を当てはめていくという、いわば全数チェックでの解法を使いました。考察するまでもなく、かなりの無駄がある事は明白です。
　こちらの最終完成版の ダウンロード

数独（ナンプレ）を解くアルゴリズムの要点とパフォーマンスの検証№1

　数独（ナンプレ）を解くアルゴリズムを例に、アルゴリズムの要点と、それによるパフォーマンスを検証します、
　 数独（ナンプレ）を解くVBAに挑戦
　数独は、一般に「ナンバープレース（ナンプレ）」と呼ばれ、外国では「sudoku」と呼ばれているようです、この数独をExcelマクロVBAで解いてみようと言う事です。解き方は、とにかく片っ端から数字を当てはめていくという、なんとも芸の無い方法です。
　ここでは、とにかく全ての数字を当てはめていくという、いわば全数チェックでの解法を使いました。
　考察するまでもなく、かなりの無駄がある事は明白です。
　しかし、このアルゴリズムは、間違いなく解を得る事ができ、かつ、そのアルゴリズムは非常に簡単なものです。
　言わば、より良いアルゴリズムが不明な場合に、最期の手段といえるものでもあります。
　さらに、このアルゴリズムは、絶対に不可欠なものでもあります。
　少なくとも、数独を解く場合には、最期に複数候補のマスが複数残ってしまった場合には、
　この全数チェックを行う事は必然であり、最も確実な方法でもあります。
　とはいえ、最初から全数チェックは、いかにも芸がなく、PCのパフォーマンスに全てを委ねてしまっています。
　この全数チェックの試行回数が膨大であり、間違いなく無駄だと感じます。
　もっと効率的なアルゴリズムがあるはずです。
　数独を解く場合のセオリーはいくつかあるようです。
　しかし、ここでは、そのような一般的な数独を解くセオリー等は考慮せず、
　あくまで、プログラミングのテクニックで、より有効なアルゴリズムを探してみたいと思います。
　各マスに入れられる数値は1～9の全てではなく、縦・横・枠内に重複しない数値のみ入れられる訳です。
　概ね、１つのマスに入れられる数値の種類は、2～6程度になります。
　もちろん、初級問題なら、いきなり１つしか入れられないマスもあったり、
　上級問題なら、7つも入れられる可能性のあるマスも存在はするでしょうが・・・
　では、全数チェックすると言う事は、その組み合わせは、
　入れる事が可能な候補数値の掛け算になってしまいます。
　6×6×5×5×4×4×3×3×2×2
　10個のマスでも、とんでもない組み合わせ数になってしまいます。
　でも、先のアルゴリズムは、本当に全数チェックをしているのでしょうか？
　そんな事はありませんね、全数チェックしていたら、とても短時間で解を求めることなど無理ですから。
　数値を仮置きし、次のマスに進む、これ繰り返していくと、どこかで破綻します。
　つまり、1～9のいずれの数値も入れられなくなってしまう状態が発生します。
　その場合は、手前に戻って、数値を入れ直します。
　つまり、破綻した時点で、それ以降はチェックしていないのです。
　 数独（ナンプレ）を解くVBAに挑戦
　
Option Explicit
　 Private tryCnt As Long
　Sub main()
　　　Debug.Print Timer
　　　Dim SuAry(1 To 9, 1 To 9) As Integer
　　　Dim i1 As Integer
　　　Dim i2 As Integer
　 tryCnt = 0
　　　Erase SuAry
　　　For i1 = 1 To 9
　　　　　For i2 = 1 To 9
　　　　　　　If Cells(i1, i2) = "" Then
　　　　　　　　　Cells(i1, i2).Font.Color = vbBlue
　　　　　　　Else
　　　　　　　　　SuAry(i1, i2) = Cells(i1, i2)
　　　　　　　End If
　　　　　Next
　　　Next
　　　Call trySu(SuAry)
　　　Range("A1:I9").Value = SuAry
　　　Debug.Print Timer
　　　If getBlank(SuAry(), i1, i2) = False Then
　 MsgBox "解読成功" & vbLf & tryCnt
　　　Else
　　　　　MsgBox "あれれ・・・"
　　　End If
　End Sub
　Function trySu(ByRef SuAry() As Integer) As Boolean
　　　Dim i1 As Integer
　　　Dim i2 As Integer
　　　Dim su As Integer
　　　If getBlank(SuAry(), i1, i2) = False Then
　　　　　trySu = True
　　　　　Exit Function
　　　End If
　　　For su = 1 To 9
　　　　　If chkSu(SuAry(), i1, i2, su) = True Then
　　　　　　　SuAry(i1, i2) = su
　 tryCnt = tryCnt + 1
　　　　　　　Cells(i1, i2) = su
　　　　　　　If trySu(SuAry) = True Then
　　　　　　　　　trySu = True
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　End If
　　　Next
　　　SuAry(i1, i2) = 0
　　　Cells(i1, i2) = ""
　　　DoEvents
　　　trySu = False
　End Function
　Function getBlank(ByRef SuAry() As Integer, ByRef i1 As Integer, ByRef i2 As Integer) As Boolean
　　　For i1 = 1 To 9
　　　　　For i2 = 1 To 9
　　　　　　　If SuAry(i1, i2) = 0 Then
　　　　　　　　　getBlank = True
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　Next
　　　Next
　　　getBlank = False
　End Function
　Function chkSu(ByRef SuAry() As Integer, ByVal i1 As Integer, ByVal i2 As Integer, ByVal su As Integer) As Boolean
　　　Dim ix1 As Integer
　　　Dim ix2 As Integer
　　　Dim i1S As Integer
　　　Dim i2S As Integer
　　　chkSu = False
　 '横をチェック
　　　For ix2 = 1 To 9
　　　　　If ix2 <> i2 Then
　　　　　　　If SuAry(i1, ix2) = su Then
　　　　　　　　　chkSu = False
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　End If
　　　Next
　 '縦をチェック
　　　For ix1 = 1 To 9
　　　　　If ix1 <> i1 Then
　　　　　　　If SuAry(ix1, i2) = su Then
　　　　　　　　　chkSu = False
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　End If
　　　Next
　 '枠内をチェック
　　　i1S = (Int((i1 + 2) / 3) - 1) * 3 + 1
　　　i2S = (Int((i2 + 2) / 3) - 1) * 3 + 1
　　　For ix1 = i1S To i1S + 2
　　　　　For ix2 = i2S To i2S + 2
　　　　　　　If ix1 <> i1 Or ix2 <> i2 Then
　　　　　　　　　If SuAry(ix1, ix2) = su Then
　　　　　　　　　　　chkSu = False
　　　　　　　　　　　Exit Function
　　　　　　　　　End If
　　　　　　　End If
　　　　　Next
　　　Next
　　　chkSu = True
　End Function
　
※赤字の部分は、今回の検証の為に追加した部分になります。
　　　試行回数をカウントするように変更しました。
　これを実行して、じっくり眺めて下さい。
　9×9の表の中断あたりで行ったり来たり、時には下段まで行って戻ったりしています。
　つまり、下の方の空白マスはほとんどチェックされていないのです。
　つまり、候補数値が、
　6×6×5×5×4×4・・・ここで破綻
　というような事が発生しているのです。
　視点を変えて、もし、完全に全数チェックしているならば、
　6×6×5×5×4×4×3×3×2×2
　2×2×3×3×4×4×5×5×6×7
　この２つは同じになります。
　しかし、途中までなら、
　つまり、
　6×6×5×5×4×4
　2×2×3×3×4×4
　これは、明らかに後者の方が小さくなります。
　さらに見方を変えれば、候補数値の少ないマスで破綻が起こりやすいのではないかと想像できます。
　処理速度を速くするのなら、試行回数を減らせば良い訳です。
　そこで、途中で破綻する事を前提に考えるならば、
　このように、小さい数値の方からチェックした方が試行回数が少なくて済むのではないでしょうか。
　まずは、これを検証してみます。
　 №2へ続きます。
　数独を解くアルゴリズムの要点とパフォーマンスの検証 №1 №2 №3 №4
　こちらの最終完成版の ダウンロード

写真をサムネイルに変換して取り込む（Shapes.AddPicture）

　写真を取り込んだ場合、リンクすると原本が無いとみられず、
　リンクせずに取り込むとファイルサイズが巨大化してしまいます。
　そこで、サムネイルを作成し、それをセルに貼り付け、
　原本へのハイパーリンクを付けておくようにします。
　写真の取込方法については、
　 写真の取込方法について（Pictures.Insert,Shapes.AddPicture）
　
　こちらをご覧ください。
　
Sub sample()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim ws As Worksheet
　　　Dim FileName As Variant
　　　Dim dblScal As Double
　　　FileName = Application.GetOpenFilename( _
　　　　　FileFilter:="画像ファイル,*.bmp;*.jpg;*.gif", _
　　　　　MultiSelect:=True)
　　　If Not IsArray(FileName) Then
　　　　　Exit Sub
　　　End If
　　　Application.ScreenUpdating = False
　　　Set ws = Activesheet
　　　j = 1
　　　For i = LBound(FileName) To UBound(FileName)
　 'ファイル名にハイパーリンク
　　　　　ws.Hyperlinks.Add Anchor:=ws.Cells(j, 1), _
　　　　　　　　　　　　　Address:=FileName(i), _
　　　　　　　　　　　　　TextToDisplay:=FileName(i)
　 '画像の取り込み
　　　　　With ws.Shapes.AddPicture( _
　　　　　　　　　FileName:=FileName(i), _
　　　　　　　　　LinkToFile:=False, _
　　　　　　　　　SaveWithDocument:=True, _
　　　　　　　　　Left:=Selection.Left, _
　　　　　　　　　Top:=Selection.Top, _
　　　　　　　　　Width:=0, _
　　　　　　　　　Height:=0)
　 '一旦、元のサイズに戻す
　　　　　　　.ScaleHeight 1, msoTrue
　　　　　　　.ScaleWidth 1, msoTrue
　 'サイズ調整、セル内に収める
　　　　　　　If ws.Cells(j, 2).Width / .Width < ws.Cells(j, 2).Height / .Height Then
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(ws.Cells(j, 2).Width / .Width, 2)
　　　　　　　Else
　　　　　　　　　dblScal = WorksheetFunction.RoundDown(ws.Cells(j, 2).Height / .Height, 2)
　　　　　　　End If
　　　　　　　.Width = .Width * dblScal
　　　　　　　.Height = .Height * dblScal
　 .Cut
　　　　　End With
　 ' サムネイルの作成
　　　　　ws. PasteSpecia l Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
　　　　　With ws.Shapes(ws.Shapes.Count)
　　　　　　　.Top = ws.Cells(j, 2).Top
　　　　　　　.Left = ws.Cells(j, 2).Left
　　　　　　　ws.Hyperlinks.Add Anchor:=ws.Shapes(ws.Shapes.Count), Address:=FileName(i)
　　　　　End With
　　　　　j = j + 1
　　　Next
　　　ws.Select
　　　ws.Range("A1").Activate
　　　Application.CutCopyMode = False
　　　Application.ScreenUpdating = True
　End Sub
写真を取り込んだ後に、切り取って（Cut）、形式を選択して貼り付けて（PasteSpecial）いるだけです。
　理屈としては、画像を縮小しただけでは解像度は変わりません。、
　そこで、切り取り・貼り付けし直すことで、画像の解像度を落としています。
　アクティブシート以外でも動作するようにしました。
　ただし、最期の写真が選択状態のままになってしまうので、
　指定シートに移動して、A1セルをSelectするようにしています。

Dir関数で全サブフォルダの全ファイルを取得

　指定フォルダ以下の全サブフォルダ内の全ファイルを取得する場合、
　通常はFileSystemObjectの再帰モジュールで実現しますが、これをDir関数だけでやってみましょう。
　
　FileSystemObjectの再帰モジュールについては、
　 エクセルでファイル一覧を作成
　
　こちらをご覧ください。
　
Sub sample()
　　　Dim i As Long
　　　Dim aryDir() As String
　　　Dim aryFile() As String
　　　Dim strName As String
　　　i = 0
　　　ReDim aryDir(i)
　　　aryDir(i) = ThisWorkbook.Path 'フォルダをここで指定
　 'まずは、指定フォルダ以下の全サブフォルダを取得し、配列aryDirに入れます。
　　　Do
　　　　　strName = Dir(aryDir(i) & "\", vbDirectory)
　　　　　Do While strName <> ""
　　　　　　　If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
　　　　　　　　　If strName <> "." And strName <> ".." Then
　　　　　　　　　　　ReDim Preserve aryDir(UBound(aryDir) + 1)
　　　　　　　　　　　aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
　　　　　　　　　End If
　　　　　　　End If
　　　　　　　strName = Dir()
　　　　　Loop
　　　　　i = i + 1
　　　　　If i > UBound(aryDir) Then
　　　　　　　Exit Do
　　　　　End If
　　　Loop
　 '配列aryDirの全フォルダについて、ファイルを取得し、配列aryFileに入れます。
　　　ReDim aryFile(0)
　　　For i = 0 To UBound(aryDir)
　　　　　strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
　　　　　Do While strName <> ""
　　　　　　　If aryFile(0) <> "" Then
　　　　　　　　　ReDim Preserve aryFile(UBound(aryFile) + 1)
　　　　　　　End If
　　　　　　　aryFile(UBound(aryFile)) = aryDir(i) & "\" & strName
　 '実行結果が分かりやすいように、テスト的にセルに書き出す場合
　 'Cells(UBound(aryFile) + 1, 1) = aryFile(UBound(aryFile))
　　　　　　　strName = Dir()
　　　　　Loop
　　　Next
　End Sub
上記では、ThisWorkbook.Path以下にある、全サブフォルダが、配列aryDirに入ります。
　aryDir(0)には、最初の指定フォルダを入れています。
　これは、その後の処理を書きやすくする為と、指定フォルダ直下のファイルも一緒に取得する為に入れています。
　全サブフォルダが、配列aryDirに入ッた後は、配列aryDirに入っているフォルダを一つずつ処理し、
　全ファイルを、配列aryFileに取得しています。
　vbNormal + vbHidden + vbReadOnly + vbSystem
　この指定は、通常のファイルだけが対象なら、指定の必要はありません。
　この例では、フォルダもファイルも、配列に入れているだけですが、
　実務としては、それぞれのファイルに対する何らかの処理を記述する事になると思います。
　配列aryFileにフルパスのファイル名が入っていますので、その後の処理は書き易いはずです。
　しかし、やはりFileSystemObjectの再帰モジュールに比べると、かなり無理やり感は否めません。
　それでも、FileSystemObjectを何らかの理由で使いたくない場合には、参考になると思います。
　また、配列の使い方と、ロジックの組み立てについては、大いに参考になると思います。

ブックを開いた時に指定シートを表示（Workbook_Open）

　Workbook_Openは、ブックを開いた時に実行されるイベントです、
　VBEの「Microsoft Excel Objects」内の「ThisWorkbook」に記述します。
　
Private Sub Workbook_Open()
　　　Application.Goto Sheets(1).Range("A1"), True
　End Sub
上記では、ブックが開かれると、先頭シートのA1セルに移動しています。
　Application.Goto Sheets(1).Range("A1"), True
　これは、
　 Sheets(1).Select
　Range("A1").Select
　でも、ほぼ同じですが、
　ウインドウ枠を固定し、さらにスクロール状態で、そして固定枠内のセルが選択されている。
　このような状態でも、A1セルを選択し、スクロールも戻す必要があるなら、
　Application.Goto
　を使うと簡単に実現できます。

ブックが閉じられる直前に保存済を確認（Workbook_BeforeClose）

　Workbook_BeforeCloseは、ブックを閉じる直前に起動されるイベントです、
　手動で閉じる場合も、VBAで閉じる場合でも起動されます。
　ブックが未保存の場合、無条件でブックを保存する
　
Private Sub Workbook_BeforeClose(Cancel As Boolean)
　　　If ActiveWorkbook.Saved = False Then
　　　　　ActiveWorkbook.Save
　　　End If
　End Sub
ブックが未保存の場合は、Closeをキャンセルする。
　
Private Sub Workbook_BeforeClose(Cancel As Boolean)
　　　If ActiveWorkbook.Saved = False Then
　　　　　Cancel = True
　　　End If
　End Sub
保存済かどうかの判定は、
　 ActiveWorkbook.Saved
　これが、Trueなら保存済、Falseなら未保存状態と判定できます。
　Closeイベントを中止したい場合は、
　 Cancel = True
　とすることで、Closeイベントはキャンセルされます。

シートが選択された時に指定セルに移動（Worksheet_Activate）

　Worksheet_Activateは、シートが選択された時に実行されるイベントです、
　VBEの「Microsoft Excel Objects」内の各シートに記述します。
　
Private Sub Worksheet_Activate()
　　　Application.Goto Range("A1"), True
　End Sub
上記では、シートが選択されたとき、A1セルに移動しています。
　Application.Goto Range("A1"), True
　これは、
　
　Range("A1").Select
　でも、ほぼ同じですが、
　ウインドウ枠を固定し、さらにスクロール状態で、そして固定枠内のセルが選択されている。
　このような状態でも、A1セルを選択し、スクロールも戻す必要があるなら、
　Application.Goto
　を使うと簡単に実現できます。

ダブルクリックで行高・列幅調整（Worksheet_BeforeDoubleClick）

　セルをダブルクリックすることで、そのセル値で行高および列幅を自動調整するマクロVBAになります。
　これは、以下の操作をマクロVBAでまとめて行うことになります。
　 「行の高さの自動調整」
　「列の幅の自動調整」
　この二つの操作を、マクロVBAで一度にやるということです。
　ダブルクリックで起動されるVBAイベントは、BeforeDoubleClickになりますので、
　このWorksheet_BeforeDoubleClickの中で行高・列幅自動調整を行います。

Worksheet_BeforeDoubleClick

Worksheet_BeforeDoubleClickは、セルをダブルクリックした直後に起動されます。
　 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　 Target
　ダブルクリックされたセルが、Rangeオブジェクトとして渡されます。
　 Cancel
　Trueを入れると、ダブルクリックがキャンセルされます。
　具体的には、ダブルクリックでセルの編集状態になるのを防ぐことが出来ます。

行高・列幅自動調整のサンプルVBAコード


　
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　　With Target
　　　　　.Columns.AutoFit
　　　　　.Rows.AutoFit
　　　End With
　　　Cancel = True
　End Sub
Target.Columns.AutoFit
　これで、列幅を調整し、
　Target.Rows.AutoFit
　これで、行高を調整しています。
　ダブルクリックしたセルの値で行高・列幅を自動調整します。
　他の行や他の列のセル値とは関係なく、当該セルだけで自動調整されます。
　 セル結合されている場合
　行がセル結合されている場合は、行高は変化しません。
　列がセル結合されている場合は、列幅は変化しません。
　ただしセル内改行されている場合の行高については、
　結合されている行数と改行数により、行高が変化する場合があります。
　これについては、組み合わせパターンによるので、実際に試して確認してください。

英小文字が入力されたら大文字に変換（Worksheet_Change）

　Worksheet_Changeは、セルの値が変更された時に起動されます。
　 Private Sub Worksheet_Change(ByVal Target As Range)
　 Target
　変更されたセルが、Rangeオブジェクトとして渡されます。
　
Private Sub Worksheet_Change(ByVal Target As Range)
　　　Dim myRng As Range
　　　Application.EnableEvents = False
　　　For Each myRng In Target
　　　　　If Not Intersect(myRng, Columns("A")) Is Nothing Then
　　　　　　　myRng.Value = UCase(myRng.Value)
　　　　　End If
　　　Next
　　　Application.EnableEvents = True
　End Sub
上記では、A列に、小文字が入力された場合、直ちに大文字に変更しています。
　複数セルに一括で入力される場合もあるので、
　For Each myRng In Target
　これで、対象セル全てを処理しています。
　また、
　 Application.EnableEvents = False
　これで、新たなイベント発生を抑止しています。
　このがないと、VBAでセル値を変更しても、新たにWorksheet_Changeが実行されてしまいます。
　つまり、
　myRng.Value = UCase(myRng.Value)
　この時点で、再びWorksheet_Changeが起動されてしまいます。
　結果的に、イベントの連鎖が起こり、エラーとなります。
　ただし、注意しなければならない事は、
　 Application.EnableEvents = True
　これを入れ忘れると、プロシージャー終了後も、新たなイベントが発生しなくなります。

セル選択で選択行の色を変更（Worksheet_SelectionChange）

　Worksheet_SelectionChangeは、セルの選択範囲を変更した時に起動されます。
　 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　 Target
　選択されたセルが、Rangeオブジェクトとして渡されます。
　
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　　Dim myRng As Range
　　　Set myRng = Range("A2:D100")
　　　myRng.Interior.ColorIndex = xlNone
　　　If Not Intersect(myRng, Target(1)) Is Nothing Then
　　　　　Cells(Target(1).Row, myRng(1).Column).Resize(, 5).Interior.Color = RGB(150, 200, 255)
　　　End If
　End Sub
上記では、特定範囲内（A2:D100）の選択行の色を変更しています。
　If Not Intersect(myRng, Target(1)) Is Nothing Then
　これで、選択セル範囲の先頭セルが、特定範囲内（A2:D100）かの判定をしています。
　選択行の色の変更なので、見た目重視の処理になりますので、
　色を変える範囲や、何色にするか等は、いろいろやってみて良いものを選んでください。

シートを名前順に並べ替える

　シートを名前順に並べ替える方法になります。
　配列を使っていますが、配列が難しい場合は、
　シートに書き出して処理すれば良いでしょう、並べ替えもシート上なら簡単です。
　
Sub sample()
　　　Dim i As Long
　　　Dim arySht() As String
　　　For i = 1 To Sheets.Count
　　　　　If i = 1 Then
　　　　　　　ReDim arySht(0)
　　　　　Else
　　　　　　　ReDim Preserve arySht(UBound(arySht) + 1)
　　　　　End If
　　　　　arySht(UBound(arySht)) = Sheets(i).Name
　　　Next
　　　Call SheetSort(arySht)
　　　For i = UBound(arySht) To LBound(arySht) Step -1
　　　　　Sheets(arySht(i)).Move Before:=Sheets(1)
　　　Next
　End Sub
　Sub SheetSort(ByRef argAry() As String)
　　　Dim sSwap As String
　　　Dim i As Integer
　　　Dim j As Integer
　　　For i = LBound(argAry) To UBound(argAry)
　　　　　For j = UBound(argAry) To i Step -1
　　　　　　　If argAry(i) > argAry(j) Then
　　　　　　　　　sSwap = argAry(i)
　　　　　　　　　argAry(i) = argAry(j)
　　　　　　　　　argAry(j) = sSwap
　　　　　　　End If
　　　　　Next j
　　　Next i
　End Sub
上記では、シート名を文字列として処理しています。
　どういう事かと言うと、
　3000
　10000
　200
　このようなシート名の場合、
　10000 < 200 < 3000
　となってしまいます。
　数値として比較したい場合は、
　Dim arySht() As String → Dim arySht() As Long
　Sub SheetSort(ByRef argAry() As String) → Sub SheetSort(ByRef argAry()As Long)
　このようにすれば、数値として比較されます。

グラフで特定の横軸の色を変更し基準線を引くマクロ

　特定の横軸のみ色を変更する、つまり、基準値や下限・上限等に線を引きたい場合のマクロVBAになります。
　手動でやろえとすると結構面倒なので、いざやろうとするとなかなか出来なかったりします。
　グラフの元データに線を引きたい数値の系列をシートに追加しておくと、もう少し楽にできますが、
　ここでは、シートには手を加えずに基準線を引いています。
　手動でやる方法については、以下に掲載しています。
　 グラフで特定の横軸の色を変更し基準線を引く
　特定の横軸のみ色を変更する、つまり、基準値や下限・上限等に線を引く場合の手順です 基準値や、下限・上限等に線を引きたい場合になります。結構面倒なので、いざやろうとすると、なかなか出来なかったりしますので、自分自身の覚書を兼ねて掲載しておきます。
　今回は、これをマクロVBAで行います。
　 あらかじめ棒グラフがあるものとして、そこに 赤の規準線 （ここでは 平均値 ）を引くマクロVBAになります。
　上記サンプルでは２系列となっていますが、系列数は問いません、自動で行います。

グラフで特定の横軸の色を変更する（基準線を引く）VBA


　
Sub sample()
　　　Dim TitleHas As Boolean
　　　Dim TitleFormula As String
　　　Dim 基準値 As Double
　　　Dim vTemp, v1, v2
　　　Dim i As Long
　 'シートの先頭グラフ
　　　Dim obj As Chart
　　　Set obj = ActiveSheet.ChartObjects(1).Chart
　　　With obj
　 '基準値決定：平均値を求める
　　　　　For i = 1 To .SeriesCollection.Count
　 'シート名に,カンマは含んでいない前提です
　　　　　　　vTemp = Split(.SeriesCollection(i).Formula, ",")
　　　　　　　vTemp = vTemp(UBound(vTemp) - 1)
　　　　　　　v1 = v1 + WorksheetFunction.Sum(Range(vTemp))
　　　　　　　v2 = v2 + WorksheetFunction.Count(Range(vTemp))
　　　　　Next
　　　　　If v2 <> 0 Then 基準値 = v1 / v2
　 '系列追加でタイトルが消える事への対応
　　　　　TitleHas = .HasTitle
　　　　　If TitleHas Then TitleFormula = .ChartTitle.Formula
　 '基準線を新規系列として追加
　　　　　With .SeriesCollection.NewSeries
　　　　　　　.Name = "=""規準""" '特に必要はない
　 '.Values = "={基準値,基準値}"
　　　　　　　.Values = "={" & Join(Array(基準値, 基準値), ",") & "}"
　　　　　　　.ChartType = xlLine '折れ線
　　　　　　　.AxisGroup = 2 '第2軸
　　　　　　　.Format.Line.ForeColor.RGB = vbRed 'RGB(255, 0, 0)
　　　　　End With
　 '系列追加で消えたタイトルの復元
　　　　　.HasTitle = TitleHas
　　　　　If TitleHas Then .ChartTitle.Formula = TitleFormula
　 '第2縦軸のScaleを第1縦軸に合わせる
　　　　　.Axes(xlValue, 2).MinimumScale = .Axes(xlValue, 1).MinimumScale
　　　　　.Axes(xlValue, 2).MaximumScale = .Axes(xlValue, 1).MaximumScale
　　　　　.Axes(xlValue, 2).Delete '第2軸を消す
　 'グラフ内左右余白を消す：基準線を第2横軸に設定
　　　　　.HasAxis(xlCategory, 2) = True '第2横軸表示
　　　　　.Axes(xlCategory, 2).AxisBetweenCategories = False '軸位置を目盛
　　　　　.Axes(xlCategory, 2).TickLabelPosition = xlNone '目盛ラベルなし
　 '基準線の凡例を消す
　　　　　On Error Resume Next '凡例が無いときの対応
　　　　　.Legend.LegendEntries(.SeriesCollection.Count).Delete
　　　End With
　End Sub

基準線を引くマクロVBAの解説

以下、基準線を引くマクロVBAの中から、要点・注意点のみ解説します。
　 ActiveSheet.ChartObjects(1)
　シートの先頭グラフになります。
　複数のグラフがある場合は適宜変更してください。
　 基準値決定：平均値を求める
　グラフの元データから平均値を求めています。
　簡易的に,カンマで区切ってデータ範囲を取得していますので、
　あまり無いとは思いますが、'シート名に,カンマを含んでいると正しく取得できません。
　また、クラフのデータ範囲として固定数値を直接指定しているとエラーとなります。
　.SeriesCollection(i).Formulaの値は、
　=SERIES(Sheet1!$B$1 , Sheet1!$A$2:$A$13 , Sheet1!$B$2:$B$13 , 1)
　このような文字列になりますので、カンマ区切りで後ろから2番目がデータ範囲になります。
　この文字列(Sheet1!$B$2:$B$13)を取り出して、Rangeの引数に入れてRangeオブジェクトにしています。
　あくまで、基準値を求める一つのサンプルになります。
　あらかじめ決められた基準値なら、変数（基準値）にその値を入れてください。
　シート上で数式により計算していれば、そのセル値を変数（基準値）に入れてください。
　 基準線を新規系列として追加
　.SeriesCollection.NewSeries
　これで系列を追加しています。
　Valuesには、
　.Values = "={基準値,基準値}"
　このように設定しますので、この文字列を作成してValuesに入れています。
　そして、折れ線に設定し、第2軸に設定しています。
　色の指定は、vb定数でもRGB関数でも有効な指定なら何でも構いません。
　 系列追加でタイトルが消える事への対応と復元
　系列を追加すると、タイトルが消えてしまいますので、
　系列追加前に情報を退避しておき、系列追加後に戻しています。
　タイトルには、数式を設定できますので、Formulaを使っています。
　 第2縦軸のScaleを第1縦軸に合わせる
　基準線を第2縦軸に設定するので、第2縦軸の最大値と最小値を第1縦軸と同じにしています。
　そして、第2縦軸の表示は必要ないので消しています。
　, 2 )や, 1 )は、縦軸の数値です。
　第1縦軸は、xlPrimary=1
　第2縦軸は、xlSecondary=2
　上記VBAでは、掲載コードの見やすさを考慮して数値リテラルで指定しています。
　 グラフ内左右余白を消す：基準線を第2横軸に設定
　基準線を横幅いっぱいに広げるために、
　・第2横軸に設定
　・軸位置を目盛
　・目盛ラベルなし
　 基準線の凡例を消す
　凡例に追加した基準線の系列が表示されてしまうので、これを消しています。
　もちろん、凡例に表示されていた方が良ければ消さずに残してください。
　ほぼ全て自動になっていますので、大抵の場合は修正せずに使えると思います。
　手動で一つずつ設定するよりは間違いなく早いはずです。
　特に複数グラフで設定したい場合には有効だと思いますので、VBAでできる事だけは覚えておくと良いでしょう。

ブックを開かずにセル値を取得（ExecuteExcel4Macro,Excel.Application）

　「ブックを開かずにセル値を取得」に関する検索が非常に多いようです。
　おそらく、ExecuteExcel4Macroに関連しているとか、
　もしくは、大量のファイルがある為、マクロVBAの処理時間がかかってしまうと言うものでしょう。
　ExecuteExcel4Macroについての簡単な解説は、「 ExecuteExcel4Macroについて 」
　ExecuteExcel4Macroは、Excel4.0のマクロを実行します。つまり、昔のマクロを使うということです。VBAが使える前 にあったものですが、最新バージョンのエクセルでも使用できます。とはいえ、積極的に使うようなものでもないですし、MSもVBAへの移行を勧めていま す。
　サンプルを通して、方法論を解説します。
　以下では、マクロ記述してExcelファイルと同一フォルダ内の"test"サブフォルダの全Excelファイルについて処理します。
　"test"フォルダには、100KB強のExcelファイルを100個入れて、以下のテストを実行しています。

ExecuteExcel4Macroで１個のセル値を取得


　
Sub sample1()
　　　Dim i As Long
　　　Dim strDir As String
　　　Dim strFile As String
　　　Debug.Print Timer
　　　Application.ScreenUpdating = False
　　　strDir = ThisWorkbook.Path & "\test\"
　　　strFile = Dir(strDir)
　　　i = 1
　　　Do While strFile <> ""
　 Cells(i, 1) = ExecuteExcel4Macro("'" & strDir & "[" & strFile & "]Sheet1'!R1C1")
　　　　　strFile = Dir()
　　　　　i = i + 1
　　　Loop
　　　Application.ScreenUpdating = True
　　　Debug.Print Timer
　End Sub
"Sheet1"のA1セルのみ取得しています。
　この処理は非常に速いです。
　私の環境では、 0..3秒 程度で完了します。

Excel.Applicationで１個のセル値を取得


　
Sub sample2()
　　　Dim i As Long
　　　Dim strDir As String
　　　Dim strFile As String
　 Dim xls As New Excel.Application
　　　Dim wb As Workbook
　　　Debug.Print Timer
　　　Application.ScreenUpdating = False
　　　strDir = ThisWorkbook.Path & "\test\"
　　　strFile = Dir(strDir)
　　　i = 1
　　　Do While strFile <> ""
　 Set wb = xls.Workbooks.Open(strDir & strFile)
　 Cells(i, 1) = wb.Worksheets("Sheet1").Range("A1")
　 wb.Close Savechanges:=False
　　　　　strFile = Dir()
　　　　　i = i + 1
　　　Loop
　 Set xls = Nothing
　　　Application.ScreenUpdating = True
　　　Debug.Print Timer
　End Sub
"Sheet1"のA1セルのみ取得しています。
　私の環境では、 11秒 程度で完了します。
　この処理は、ExecuteExcel4Macroに比べたら遅いのですが、
　 New Excel.Application とExcelインスタンスを生成せずに、
　普通に、Workbooks.Open(strDir & strFile)とやるよりは、はるかに高速に動作します。
　これですと、3～4分程度の時間はかかってしまうはずです。

ExecuteExcel4Macroで100個のセル値を取得


　
Sub sample1_2()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim strDir As String
　　　Dim strFile As String
　　　Debug.Print Timer
　　　Application.ScreenUpdating = False
　　　strDir = ThisWorkbook.Path & "\test\"
　　　strFile = Dir(strDir)
　　　i = 1
　　　Do While strFile <> ""
　　　　　For j = 1 To 100
　 Cells(i, j) = ExecuteExcel4Macro("'" & strDir & "[" & strFile & "]Sheet1'!R1C" & j)
　　　　　Next
　　　　　strFile = Dir()
　　　　　i = i + 1
　　　Loop
　　　Application.ScreenUpdating = True
　　　Debug.Print Timer
　End Sub
"Sheet1"のA1～CV1セルの取得をしています。
　私の環境では、 約30秒 程度で完了します。
　sample1の１個のセル取得に比べて、約100倍の時間がかかっています。
　これは、単純に、 ExecuteExcel4Macro の実行回数に比例していると言う事になります。

Excel.Applicationで100個のセル値を取得


　
Sub sample2_2()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim strDir As String
　　　Dim strFile As String
　 Dim xls As New Excel.Application
　　　Dim wb As Workbook
　　　Debug.Print Timer
　　　Application.ScreenUpdating = False
　　　strDir = ThisWorkbook.Path & "\test\"
　　　strFile = Dir(strDir)
　　　i = 1
　　　Do While strFile <> ""
　 Set wb = xls.Workbooks.Open(strDir & strFile)
　　　　　For j = 1 To 100
　 Cells(i, 1) = wb.Worksheets("Sheet1").Cells(1, j)
　　　　　Next
　 wb.Close Savechanges:=False
　　　　　strFile = Dir()
　　　　　i = i + 1
　　　Loop
　 Set xls = Nothing
　　　Application.ScreenUpdating = True
　　　Debug.Print Timer
　End Sub
"Sheet1"のA1～CV1セルの取得をしています。
　私の環境では、 約45秒 程度で完了します。
　sample2の１個のセル取得に比べて、約4倍程の時間がかかっています。
　しかし、データ個数の増加に比べると短い時間で済んでいます。
　これは、セル値の取得より、ブックのOpenに時間がかかっている為です。
　しかし、ちょっと考えてみて下さい。
　連続したセル値を取得するなら、もっと効率的な記述ができます。

Excel.Applicationで100個のセル値を取得2


　
Sub sample2_3()
　　　Dim i As Long
　　　Dim strDir As String
　　　Dim strFile As String
　 Dim xls As New Excel.Application
　　　Dim wb As Workbook
　　　Dim ws As Worksheet
　　　Debug.Print Timer
　　　Application.ScreenUpdating = False
　　　strDir = ThisWorkbook.Path & "\test\"
　　　strFile = Dir(strDir)
　　　i = 1
　　　Do While strFile <> ""
　 Set wb = xls.Workbooks.Open(strDir & strFile)
　 Set ws = wb.Worksheets("Sheet1")
　 Range(Cells(i, 1), Cells(i, 100)).Value = ws.Range(ws.Cells(1, 1), ws.Cells(1, 100)).Value
　　　　　wb.Close Savechanges:=False
　　　　　strFile = Dir()
　　　　　i = i + 1
　　　Loop
　 Set xls = Nothing
　　　Application.ScreenUpdating = True
　　　Debug.Print Timer
　End Sub
私の環境では、 約14秒 程度で完了します。
　sample2の１個のセル取得と、ほとんど変わっていません。
　つまり、
　 Cells(i, 1) = wb.Worksheets("Sheet1").Range("A1")
　と
　 Range(Cells(i, 1), Cells(i, 100)).Value = ws.Range(ws.Cells(1, 1), ws.Cells(1, 100)).Value
　これは、ほとんど処理時間に差が無いと言うことになります。

ブックを開かずにセル値を取得

おもに、処理時間について考察しましたが、
　ExecuteExcel4Macroには、重大な欠点があります。
　それは、シート名が固定でなければ取得できないことです。
　別の方法で、ブックを開かずにシート名を取得する方法はあります。
　 Excelファイルを開かずにシート名を取得
　Excelファイルを開くときは、ファイルサイズに比して、とても遅い場合があります、ファイルを開かずに、Excelの情報を取得したいとい う要望は少なからずあるようです、そこで、処理の基本となるシート名を取得する方法になります。もちろん、開かないと言っても、厳密には必ず開いているわ けですが、Excelのブックとして開かないという事です。
　 ExecuteExcel4Macro("'" & strDir & "[" & strFile & "]Sheet1'!R1C1")
　この、 Sheet1 は固定で記述しなければなりません。
　つまり、シート名が不明な場合はExecuteExcel4Macroは使えないのです。
　 Excel.Application を利用した方法なら、
　先頭シート、Worksheets(1)のように記述も出来ますし、もちろん全シートに対しての処理も問題ありません。
　 結論として、ExecuteExcel4Macroが有用なのは、
　 ・ファイル数が極めて多い
　・シート名が固定されている
　・取得するセル数が限定的である事
　ということになります。
　なお、「 ExecuteExcel4Macroについて 」にもある通り、ExecuteExcel4Macroでは関数も使えます。
　ExecuteExcel4Macroは、Excel4.0のマクロを実行します。つまり、昔のマクロを使うということです。VBAが使える前 にあったものですが、最新バージョンのエクセルでも使用できます。とはいえ、積極的に使うようなものでもないですし、MSもVBAへの移行を勧めていま す。
　ただし、単一の値を取得する関数に限られます。
　 余程の事情が無い限り、ExecuteExcel4Macroは積極的に使うものではないでしょう。

素数を求めるマクロ

　素数とは、1 と自分自身以外に正の約数を持たない、1でない自然数のことです、
　この素数を求めて、シートに出力するマクロになります。
　特に何かに使えると言う事もないので、
　PCの計算能力って、どの程度なのかを実感してみるくらいの事でしょうか。
　
Sub 素数を求める()
　　　Dim i As Long
　　　Dim j As Long
　　　Dim m As Long
　　　Dim p As Long
　　　i = 1
　　　j = 1
　　　p = 2
　　　Do
　　　　　If 素数判定(p) Then
　　　　　　　Cells(i, j) = p
　　　　　　　i = i + 1
　　　　　　　If i > Rows.Count Then
　　　　　　　　　i = 1
　　　　　　　　　j = j + 1
　　　　　　　End If
　　　　　End If
　　　　　p = p + 1
　　　Loop
　End Sub
　Function 素数判定(ByVal p As Long) As Boolean
　　　素数判定 = False
　　　Dim m As Long
　　　If p = 2 Then Exit Function
　　　For m = 2 To Int(Sqr(p))
　　　　　If p Mod m = 0 Then
　　　　　　　Exit Function
　　　　　End If
　　　Next
　　　素数判定 = True
　End Function
注意
　このマクロはオーバーフローするまで停止しません。
　そこに至るまでの時間は、ものすごーくかかります。
　停止する場合は、「Esc」連打等で止めてください。
　素数の求め方については、別途調べて頂きたいのですが、
　簡単に説明すると、
　2からその数までの整数で割り切れるかどうか・・・
　割り切れる数がある場合は素数ではなく、
　割り切れる数がない場合に素数となります。
　ただし、実際には、
　2からその数まで確認する必要がなく、
　その数の平方根まで確認すれば良い事になります。
　これをマクロで書いたものが上記になります。
　A列から出力し、最終列までいったら、次の列に進みます。
　変数pはLongを使っているので、2,147,483,647を超えた時点で型エラーが発生するはずです。
　でもね私のPCでは、時間がかかりすぎて、そこまで確認できていません。
　pが億の単位で諦めました。
　数が大きくなるに従い、処理時間がかかりますので、
　そこから、20億までは、まだまだかかりそうなので中断しました。
　PCって、案外大したことないんですよね。

入力規則のリスト入力を確認する

　入力規則のリスト入力は、Excelの機能の中でも頻繁に使われる機能です、
　目的の１つとして、リスト内のデータのみの入力に限定したいと言う事がありますが、
　コピペで値の貼り付けを行うと、どんな値も入力出来てしまいます。
　結果として、意図しない値が入力されてしまう事があります。
　これを、入力規則のリスト内のデータが正しく入力されたかどうか判定する方法になります。
　
Sub sample()
　　　Dim rng As Range
　　　For Each rng In Selection
　　　　　If isValidationOk(rng) = False Then
　　　　　　　MsgBox rng.Address & "：入力値不正"
　　　　　End If
　　　Next
　End Sub
　Function isValidationOk(ByRef rng As Range) As Boolean
　　　Dim i As Integer
　　　Dim strList As String
　　　Dim strSplit() As String
　　　On Error Resume Next
　　　With rng
　 '入力規則のリストかどうか
　　　　　If .Validation.Type = xlValidateList Then
　 '入力規則がない場合はエラーが発生するので
　　　　　　　If Err.Number > 0 Then
　　　　　　　　　Err.Clear
　　　　　　　　　isValidationOk = True
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　Else
　 '入力規則のリスト以外はチェックしない
　　　　　　　isValidationOk = True
　　　　　　　Exit Function
　　　　　End If
　 '入力規則のリストのデータを配列に取得
　　　　　If Left(.Validation.Formula1, 1) = "=" Then
　 'リストがセル範囲指定の場合
　　　　　　　With Range(Mid(.Validation.Formula1, 2))
　　　　　　　　　ReDim strSplit(.Count - 1)
　　　　　　　　　For i = 1 To .Count
　　　　　　　　　　　strSplit(i - 1) = .Item(i).Value
　　　　　　　　　Next
　　　　　　　End With
　　　　　Else
　 'リストデータが直接指定の場合
　　　　　　　strSplit = Split(.Validation.Formula1, ",")
　　　　　End If
　 '入力規則のリスト配列にあるかの判定
　　　　　For i = LBound(strSplit) To UBound(strSplit)
　　　　　　　If strSplit(i) = .Value Then
　　　　　　　　　isValidationOk = True
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　Next
　 '入力規則のリスト配列にないのでエラー
　　　　　isValidationOk = False
　　　　　Exit Function
　　　End With
　End Function
sampleでは、選択セル範囲において、入力規則のリスト内のデータか判定し、
　それ以外が入力されている場合は、メッセージを表示しています。
　入力規則において、
　直接、リストデータを入れている場合は、
　Range.Validation.Formula1
　に、"A,B,C,・・・"のように、文字列として入っていますが、
　他のセル範囲を参照している場合は、
　"="に続けてセル範囲のアドレスが入っています。
　そこで、セル範囲の値を取得し、そのセル範囲の値になっているかを確認する必要があります。
　本来、入力規則まで設定してあるのに、他の値を入れてしまう事自体に問題があり、
　それは、使用者に対する注意事項として伝えるへきものではありますが、
　万一、リスト以外のデータが入力されてしまった場合に、その後の処理に支障をきたすのであれば、
　やはりチェックしておく必要出てきます。
　そのような場合があれば、参考にして下さい。

配色を使用したカラー設定を固定カラーに再設定

　Excel2007以降なら配色を選択して作成した場合、
　作成したシートを他のブックに移すと、色が変わってしまいます、
　そこで、配色ではなく、RGB値で色を再設定することで、
　元々の色をそのままにして、他のブックに移すことが出来ます。
　以下は、この目的で色を再設定するマクロVBAになります。
　
Sub sample()
　　　Dim ws As Worksheet
　　　Dim rng As Range
　　　Dim gc As ChartObject
　　　Dim sc As Series
　　　Set ws = ActiveSheet
　 'セルの塗りつぶしを再設定
　　　For Each rng In ws.UsedRange
　　　　　If rng.Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　　rng.Interior.Color = rng.Interior.Color
　　　　　End If
　　　Next
　 'グラフの色を再設定
　　　For Each gc In ws.ChartObjects 'グラフのコレクション
　　　　　For Each sc In gc.Chart.SeriesCollection '系列のコレクション
　　　　　　　With sc
　　　　　　　　　Select Case sc.ChartType
　　　　　　　　　　　Case XlChartType.xlColumnClustered '棒グラフ
　　　　　　　　　　　　　If .Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　.Interior.Color = .Interior.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　　　If .Border.ColorIndex <> xlColorIndexNone And _
　　　　　　　　　　　　　　　.Border.ColorIndex <> xlColorIndexAutomatic Then
　　　　　　　　　　　　　　　.Border.Color = .Border.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　Case XlChartType.xlLine '折れ線グラフ
　　　　　　　　　　　　　If .Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　.Interior.Color = .Interior.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　　　If .Border.ColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　.Border.Color = .Border.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　Case XlChartType.xlLineMarkers 'マーカー付き折れ線グラフ
　　　　　　　　　　　　　If .Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　.Interior.Color = .Interior.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　　　If .Border.ColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　.Border.Color = .Border.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　　　If .MarkerForegroundColor >= 0 Then
　　　　　　　　　　　　　　　If .MarkerForegroundColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　　　.MarkerForegroundColor = .MarkerForegroundColor
　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　.MarkerForegroundColor = .Border.Color
　　　　　　　　　　　　　End If
　　　　　　　　　　　　　If .MarkerBackgroundColor >= 0 Then
　　　　　　　　　　　　　　　If .MarkerBackgroundColorIndex <> xlColorIndexNone Then
　　　　　　　　　　　　　　　　　.MarkerBackgroundColor = .MarkerBackgroundColor
　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　.MarkerBackgroundColor = .Border.Color
　　　　　　　　　　　　　End If
　　　　　　　　　End Select
　　　　　　　End With
　　　　　Next
　　　Next
　End Sub
上記のマクロVBAでは、セルの塗りつぶしと、グラフについて対応しています。
　他に、オートシェイプ等々もありますが、考え方は同じになります。
　また、グラフについては、
　・棒グラフ
　・折れ線グラフ
　・マーカー付き折れ線グラフ
　この３種類について対応しています。
　同じコードで設定できるグラフも多いのですが、基本的にグラフ毎にクセがありますので、どのプロパティを変更するかが変わります。
　特に自動設定となるプロパティが問題です。
　上記のマクロなら、
　マーカー付き折れ線グラフのMarkerForegroundColorやMarkerBackgroundColorになります。
　この場合は、値に-1が入っている場合があり、その場合はBorder.Colorと同じになります。
　探せばどこかに資料があるかもしれませんが、実際にVBAをステップ実行してカラー値を確認した方が早いと思います。
　上記マクロでは配色のみ対応していますが、テーマにより見た目が変わります。
　テーマによる変更は確認していませんが、これよりはるかに複雑な処理が必要になる事は間違いありません。
　従って、テーマや配色は極力使用しない事をお勧めします。
　標準のOfficeで使うか、その他の色で直接に色を設定するようにしましょう。
　もし、テーマや配色を使用するなら、
　シートを使いまわし他のブックに移す等は絶対にしない事が前提となります。

グラフのデータ範囲を自動拡張するマクロ

　グラフのデータ範囲を自動で拡張・縮小するマクロVBAになります、
　グラフのデータ範囲を変更する事は度々ありますが、
　作業自体は大した事はないのですが、やはり面倒ですし、
　グラフの数が多いと、結構な手間になります。
　 注意
　　以下は、棒グラフ・折れ線グラフの場合になります。
　　積み上げグラフで、系列を積み上げる場合は、系列が増えてしまいますので、このマクロでは対応できません。
　　そのような場合は、系列を追加するマクロVBAが必要となります。
　まずは簡単なところで
　
Sub sample1()
　　　Dim i As Long, F As String, lngMax As Long
　　　lngMax = Cells(Rows.Count, 1).End(xlUp).Row
　　　With ActiveSheet.ChartObjects(1).Chart
　　　　　For i = 1 To .SeriesCollection.Count
　　　　　　　.SeriesCollection(i).Formula = _
　　　　　　　　　"=SERIES(" & _
　　　　　　　　　Cells(1, i + 1).Address(External:=True) & "," & _
　　　　　　　　　Cells(2, 1).Resize(lngMax - 1, 1).Address(External:=True) & "," & _
　　　　　　　　　Cells(2, i + 1).Resize(lngMax - 1, 1).Address(External:=True) & "," & _
　　　　　　　　　i & ")"
　　　　　Next i
　　　End With
　End Sub
このマクロは、A列にX軸名、1行目に系列名があり
　データが連続したセルにあることを前提にしています。
　どんなグラフ範囲でも対応するとなると、結構面倒になります。
　
Sub sample2()
　　　Dim i As Long '系列のFor～Nextで使用
　　　Dim rowMin As Long 'グラフデータ範囲の開始行
　　　Dim rowMax As Long 'グラフデータ範囲の最終行
　　　Dim strFormula As String 'グラフデータ範囲の設定文字列
　　　Dim strExternal() As String 'グラフのSERIES関数の引数毎に分割した文字列
　　　Dim strAddress() As String 'ADDRESS文字列をシートとRANGE指定に分割した文字列
　　　Dim newAddress1 As String 'SERIES関数の新しい系列名のADDRESS
　　　Dim newAddress2 As String 'SERIES関数の新しい系列値のADDRESS
　　　Dim curRng As Range 'グラフデータのセル範囲
　 'Chartオブジェクトに対する処理
　　　With ActiveSheet.ChartObjects(1).Chart
　 '全系列に対する処理
　　　　　For i = 1 To .SeriesCollection.Count
　 'グラフデータ範囲の設定文字列
　　　　　　　strFormula = .SeriesCollection(i).Formula
　 '=SERIES(引数・・・)を引数だけにする
　　　　　　　strFormula = Replace(Replace(strFormula, "=SERIES(", ""), ")", "")
　 'SERIES関数の引数毎に分割
　　　　　　　strExternal = Split(strFormula, ",")
　 '系列名（SERIES関数の第2引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(1), "[" & ThisWorkbook.Name & "]", ""), "!")
　　　　　　　strAddress(0) = Replace(strAddress(0), "'", "") 'シートの前後の'を削除
　 '系列名の開始行
　　　　　　　rowMin = Worksheets(strAddress(0)).Range(strAddress(1)).Item(1).Row
　 '系列名の最終行
　　　　　　　Set curRng = Worksheets(strAddress(0)).Range(strAddress(1)).CurrentRegion
　　　　　　　rowMax = curRng.Item(curRng.Count).Row
　 'SERIES関数の新しい系列名のADDRESS
　　　　　　　newAddress1 = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1).Address(External:=True)
　 '系列値（SERIES関数の第3引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(2), "[" & ThisWorkbook.Name & "]", ""), "!")
　　　　　　　strAddress(0) = Replace(strAddress(0), "'", "") 'シートの前後の'を削除
　 'SERIES関数の新しい系列値のADDRESS
　　　　　　　newAddress2 = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1).Address(External:=True)
　 'グラフデータ範囲の再設定
　 　　　　　　.SeriesCollection(i).Formula = "=SERIES(" & _
　　　　　　　　　　　　　　　　　　　　　　　strExternal(0) & "," & _
　　　　　　　　　　　　　　　　　　　　　　　newAddress1 & "," & _
　　　　　　　　　　　　　　　　　　　　　　　newAddress2 & "," & _
　　　　　　　　　　　　　　　　　　　　　　　i & ")"
　　　　　Next i
　　　End With
　End Sub
上記なら、現在のグラフのデータ範囲から、連続セル範囲を再取得しているので、
　大抵の場合は、大丈夫でしょう。
　上記は、以下のように、
　 Values プロパティ
　 XValues プロパテイ
　への設定でも可能です。
　
Sub sample3()
　　　Dim i As Long '系列のFor～Nextで使用
　　　Dim rowMin As Long 'グラフデータ範囲の開始行
　　　Dim rowMax As Long 'グラフデータ範囲の最終行
　　　Dim strFormula As String 'グラフデータ範囲の設定文字列
　　　Dim strExternal() As String 'グラフのSERIES関数の引数毎に分割した文字列
　　　Dim strAddress() As String 'ADDRESS文字列をシートとRANGE指定に分割した文字列
　　　Dim curRng As Range 'グラフデータのセル範囲
　 'Chartオブジェクトに対する処理
　　　With ActiveSheet.ChartObjects(1).Chart
　 '全系列に対する処理
　　　　　For i = 1 To .SeriesCollection.Count
　 'グラフデータ範囲の設定文字列
　　　　　　　strFormula = .SeriesCollection(i).Formula
　 '=SERIES(引数・・・)を引数だけにする
　　　　　　　strFormula = Replace(Replace(strFormula, "=SERIES(", ""), ")", "")
　 'SERIES関数の引数毎に分割
　　　　　　　strExternal = Split(strFormula, ",")
　 '系列名（SERIES関数の第2引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(1), "[" & ThisWorkbook.Name & "]", ""), "!")
　　　　　　　strAddress(0) = Replace(strAddress(0), "'", "") 'シートの前後の'を削除
　 '系列名の開始行
　　　　　　　rowMin = Worksheets(strAddress(0)).Range(strAddress(1)).Item(1).Row
　 '系列名の最終行
　　　　　　　Set curRng = Worksheets(strAddress(0)).Range(strAddress(1)).CurrentRegion
　　　　　　　rowMax = curRng.Item(curRng.Count).Row
　 '新しい系列名のセル範囲をValuesに設定
　 　　　　　　.SeriesCollection(i).Values = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1)
　 '系列値（SERIES関数の第3引数）の処理
　 'ADDRESS文字列をシートとRANGE指定に分割、ADDRESSにブック名が入っている場合は消去
　　　　　　　strAddress = Split(Replace(strExternal(2), "[" & ThisWorkbook.Name & "]", ""), "!")
　　　　　　　strAddress(0) = Replace(strAddress(0), "'", "") 'シートの前後の'を削除
　 '新しい系列値のセル範囲をXValuesに設定
　 　　　　　　.SeriesCollection(i).XValues = Worksheets(strAddress(0)).Range(strAddress(1)).Resize(rowMax - rowMin + 1, 1)
　　　　　Next i
　　　End With
　End Sub
sample2とsample3はほぼ同じですので、どちらでも良いでしょう。
　ブックの全シートの全グラフに対して実行する場合は、
　
Sub sample11()
　　　Dim ws As Worksheet
　　　Dim ch As ChartObject
　　　For Each ws In Worksheets
　　　　　For Each ch In ws.ChartObjects
　　　　　　　Call sumple12(ch)
　　　　　Next
　　　Next
　End Sub
　Sub sumple12(ch As ChartObject)
　　　・・・
　　　With ch.Chart
　　　　　・・・
　　　End With
　End Sub
このように外出しのSubプロシードャーでも作れば簡単に作れます。

指定セルに名前定義されているか判定する

　名前定義は、マクロVBAでは、セル位置の特定において重要な役割を持ちます、
　あるセルが名前定義されているか判定するマクロVBAになります。
　ここでは、名前定義されている場合は、その名前定義を削除するVBAサンプルとしています。

指定セル範囲が何らかの名前定義に含まれているか


　
Sub sample()
　　　Dim rng As Range
　　　Set rng = Range("A1")
　　　Call sample1(rng)
　End Sub

　
Sub sample1(rng As Range)
　　　Dim nm As Name
　　　For Each nm In Names
　　　　　If Not Intersect(rng, Range(nm.RefersTo)) Then
　　　　　　　nm.Delete
　　　　　End If
　　　Next
　End Sub
上記では、指定セルが、何らかの名前定義に含まれている場合、
　その名前定義を削除しています。
　指定セルは、単一セルである必要はありません。
　複数セルであるセル範囲で指定した場合は、
　指定されたセル範囲のいずれかのセルが、名前定義に含まれている場合に削除されます。
　これで良い場合もあるとは思いますが、ちょっと不都合な場合が多いと思います。

指定セル範囲と同一範囲の名前定義があるか


　
Sub sample()
　　　Dim rng As Range
　　　Set rng = Range("A1")
　　　Call sample2(rng)
　End Sub

　
Sub sample2(rng As Range)
　　　Dim nm As Name
　　　For Each nm In Names
　　　　　If rng.Address = nm.RefersToRange.Address Then
　　　　　　　nm.Delete
　　　　　End If
　　　Next
　End Sub
sample1との違いは、指定セル範囲が名前定義の参照範囲と完全一致で判定している事だけです。
　その使うシーンに合わせて使い分けて下さい。

すでに設定されている名前定義を削除してから再設定

単一セルに対して、名前定義を行うマクロVBAにおいて、
　すでに設定されている名前定義を削除してから再設定する場合は、
　sample2を応用して、以下のようなマクロVBAコードにすれば良いでしょう。
　
Sub sample()
　　　Dim rng As Range
　　　Set rng = Range("A1")
　　　Call sample3(rng, "NewName")
　End Sub

　
Sub sample3(rng As Range, strName As String)
　　　Dim nm As Name
　　　For Each nm In Names
　　　　　If rng.Address = nm.RefersToRange.Address Then
　　　　　　　nm.Delete
　　　　　End If
　　　Next
　　　rng.Parent.Parent.Names.Add Name:=strName, RefersToLocal:="=" & rng.Address(External:=True)
　End Sub
最後の、
　rng.Parent.Parent.Names.Add Name:=strName, RefersToLocal:="="& rng.Address(External:=True)
　この部分が、ちょっと分かりづらいかもしれません。
　Rangeの親(Parent)はSheetになり、
　そのSheetの親(Parent)はBookになります。
　つまり、てっとり早く書くなら、
　Thisworkbook.Names.Add
　や
　Activeworkbook.Add
　これで問題ありません。
　ここでは、ブックにとらわれずに、引数に指定されたRangeのBookに対して、
　名前定義をするようにする為に、
　rng.Parent.Parent.Names.Add
　このように、ちょっと回りくどい書き方をしました。
　単に名前定義の参照範囲を変更したい場合は、
　
Range("E2:G10").Name = "test"
このような書き方をすれば、名前定義が無ければ新規に名前定義されますし、
　既に名前定義が存在すれば、参照範囲が変更されます。
　ただし、この書き方ではブック範囲の名前定義しか作成できません。

マクロVBAでの名前定義について

名前定義は、マクロVBA開発において、
　フレキシブルなVBAコードにする為には必須機能となります。
　その場合に、大量の名前定義は手操作で追加するのでは大変になりますので、
　このように、マクロVBAで簡単に設定できるようにしておくと効率が良くなります。
　 第92回.名前定義（Names）｜VBA入門
　名前定義をマクロVBAで扱う場合の解説になります、名前定義は、複数セル範囲や単一セルに対して名前を付けることで、そのセル範囲を参照する 時に名前で参照できるようにするものです。名前で参照できることで、セル位置（行位置、列位置）を固定値で指定しなくて済むようになります。
　 名前定義の一覧と削除（Name）
　名前定義は使い方によっては、とても便利な機能ですが、長く使っているブックでは、とても多くの名前定義が入ってしまっていたり、参照エラーを 起こしている名前定義が多数あったりと、管理に困る場合も多々出てきます。これらが発生する原因としては、ブック間のシートコピーで増えていってしまった り、シートおよびセルの削除によって参照エラーになったままにしておくことで、

ナンバーリンク(パズル)を解くVBAに挑戦№1

　ナンバーリンクというパズルがあります、
　これをエクセルVBAで解いてみようと思います、
　 数独(ナンプレ) に続くパズルVBA解法の第二弾です。
　数独は、一般に「ナンバープレース（ナンプレ）」と呼ばれ、外国では「sudoku」と呼ばれているようです、この数独をExcelマクロVBAで解いてみようと言う事です。解き方は、とにかく片っ端から数字を当てはめていくという、なんとも芸の無い方法です。
　ナンバーリンクをご存じない方は、、
　 ウィキペディア
　 ナンバーリンクのおためし問題
　このあたりをお読みください。
　なお、サンプルで掲載した問題は、 ナンバーリンクのおためし問題 の問題1からお借りしました。
　こちらでは、回答も掲載されているので、ネタばれにならないと思いましたので。
　※もし、著作権等の問題があれば、サンプルは直ちに削除いたします。
　 ナンバーリンク問題
　 ナンバーリンクは、ルール上の制限が少ないので、
　縦横の枠数に制限はないと思われます。
　今回は、初心者向きの10×10を使用します。
　 ルール
　・盤面にある同じ数字同士を線でつなぐ。
　・線は縦横に引き、斜めには引かない（斜めに接したマス同士を直接線で結ばない）。
　・線は交差や枝分かれをしない。また、1つのマスに2本以上の線が入ることも無い。
　 回答結果
　 つまり、問題の表から、回答結果の表を作成するVBAを作成することになります。
　パズルに限らず仕事でも同じです。
　問題・課題が与えられたら、その問題・課題の本質を見極め、解決へのアプローチ方法を模索します。
　この時、いきなり複雑なことを考えず、少しずつ掘り下げていきます。
　このナンバーリンクを解くために必要な機能を考えます。
　・未処理開始セルの検索
　　・開始セルは、左上から数値セルを探す
　　・終了セルは、数値を指定して右下から探す
　　→未処理開始セルが無くなったら終了
　・線を伸ばせるセルの検索
　　→線を伸ばせるセルが無くなったら、一つ手前に戻る
　　→終了セル（同一数値）に達したら次の開始セルに進む
　私は、このように考えてみました。
　開始位置の選択は、数値の小さい順等も考えられますが、
　ルールからして、数値の大小は意味を成しませんので、左上から処理すればよいはずです。
　では、これらのVBAコード書いてみましょう。
　 №2へ続きます。
　
　 ナンバーリンク(パズル)を解くVBAに挑戦 ： №1 №2 №3 №4 №5 №6 №7 №8
　※ ナンバーリンクを解くVBAのパフォーマンス改善
　「ナンバーリンク(パズル)を解くVBAに挑戦」で作成したVBAでナンバーリンクを解く事には成功しました、しかし、10×10なら数分で解 けるものの、10×18でやったところ、4時間半もかかってしまいました。12×12では、待ちきれずに途中で止めてしまいました。
　こちらの最終完成版の ダウンロード

ナンバーリンクを解くVBAのパフォーマンス改善№1

　「 ナンバーリンク(パズル)を解くVBAに挑戦 」で作成したVBAでナンバーリンクを解く事には成功しました、
　ナンバーリンクというパズルがあります、これをエクセルVBAで解いてみようと思います、数独(ナンプレ)に続くパズルVBA解法の第二弾です。ナンバーリンクをご存じない方は、、ウィキペディア ナンバーリンクのおためし問題 このあたりをお読みください。
　しかし、
　10×10なら数分で解けるものの、
　10×18でやったところ、4時間半もかかってしまいました。
　12×12では、待ちきれずに途中で止めてしまいました。
　これでは、ちょっと実用に耐えません。
　取り急ぎ時間を短縮するなら、表示タイミングを減らせばよく、
　 Call dispCell(
　において、見る必要のない場所は、False指定にします。
　具体的には、
　行き場所がなくなり、順次戻る部分は表示を止めても、見た目は違和感を感じません。
　
tryCnt = tryCnt - 1
　Call dispCell(True,
ここをFalse指定にします、 getAdvance 内に2箇所存在します。
　ただ、確かに時間は半減しますが、
　10×10なら、これで良い気もしますが、
　10×18では、やはり時間がかかりすぎています。
　全体を見直し、無駄な記述も確認しつつ、
　新たに、ダメな進路パターンの判定を加えていきます。
　ここからは、まさに時間との勝負です。
　クイズが解けるまでの時間と、自身の費やす時間との勝負です。
　 №2へ続きます。
　
　 ナンバーリンクを解くVBAのパフォーマンス改善 ： №1 №2 №3
　こちらの最終完成版の ダウンロード

数式内の不要なシート名を削除する（HasFormula）

　複数のシートにまたがる数式を入力していると、 自身のシート名! が数式についてしまいます、
　この 自身のシート名! は不要であり、式を見づらくしてしまいます、
　この不要なシート名を、マクロVBAで一括削除します。
　ブックの全シート、全セルを対象として、
　数式の中から、 自身のシート名! を削除するマクロVBAになります。
　
Sub sample()
　　　Dim ws As Worksheet
　　　Dim rng As Range
　　　For Each ws In Worksheets
　　　　　For Each rng In ws.UsedRange
　　　　　　　If rng. HasFormula Then
　　　　　　　　　rng. Formula = Replace(rng. Formula , ws.Name & "!", "")
　　　　　　　End If
　　　　　Next
　　　Next
　End Sub
全シート処理の
　For Each ws In Worksheets
　ここは、このサイトを訪れる人には問題ないと思います。
　全セルの処理
　For Each rng In ws.UsedRange
　書き方はいろいろありますが、これが一番簡単かつ無駄が無いでしょう。
　数式の判定
　If rng. HasFormula Then
　 Rangeオブジェクト.HasFormula
　数式が設定されている場合は
　Trueが返されますので、これで判定しています。
　 自身のシート名! を削除する部分
　rng. Formula = Replace(rng. Formula , ws.Name & "!", "")
　 Rangeオブジェクト.Formula
　これは数式のプロパティですが、この他に
　 FormulaLocal
　FormulaR1C1
　等々があります。
　どれを使用しても構いませんが、
　必ず、左辺と右辺で同じものを使用してください。
　当たり前ではありますが、結構ミスしやすい部分になります。
　コードは短いですが、さくっと使えると結構便利だと思います。

Excel2003(xls)を2007以降(xlsx,xlsm)に変換する（HasVBProject）

　Excel2003形式(xls)のファイルを、一括でExcel2007以降形式(xlsx,xlsm)に変換するマクロVBAサンプルコードです。
　サンプルコードでは、サブフォルダ「Excelファイル」にあるxlsを、
　マクロ無しならxlsx、マクロ有りならxlsmにして保存しています。
　また、同名のxlsxやxlsmが存在する場合は、日時付きのファイル名にしています。
　
Sub sample()
　　　Dim i As Long
　　　Dim strArray() As String
　　　Dim strFile As String
　　　Dim strPath As String
　　　Dim strBook As String
　　　strPath = ThisWorkbook.Path & "\Excelファイル\"
　　　strFile = Dir(strPath & "*.xls")
　　　i = 0
　　　Do While strFile <> ""
　　　　　If LCase(Right(strFile, 4)) = ".xls" Then
　　　　　　　ReDim Preserve strArray(i)
　　　　　　　strArray(i) = strFile
　　　　　　　i = i + 1
　　　　　End If
　　　　　strFile = Dir()
　　　Loop
　　　For i = 0 To UBound(strArray)
　　　　　With Workbooks.Open(strPath & strArray(i))
　　　　　　　strBook = Left(strArray(i), InStrRev(strArray(i), ".") - 1)
　　　　　　　If .HasVBProject Then
　　　　　　　　　If Dir(strPath & strBook & ".xlsm") = "" Then
　　　　　　　　　　　.SaveAs filename:=strPath & strBook & ".xlsm", _
　 fileformat:=xlOpenXMLWorkbookMacroEnabled
　　　　　　　　　Else
　　　　　　　　　　　.SaveAs filename:=strPath & strBook & "_" & Format(Now(), "yyyymmddhhmmss") & ".xlsm", _
　 fileformat:=xlOpenXMLWorkbookMacroEnabled
　　　　　　　　　End If
　　　　　　　Else
　　　　　　　　　If Dir(strPath & strBook & ".xlsx") = "" Then
　　　　　　　　　　　.SaveAs filename:=strPath & strBook & ".xlsx", _
　 fileformat:=xlWorkbookDefault
　　　　　　　　　Else
　　　　　　　　　　　.SaveAs filename:=strPath & strBook & "_" & Format(Now(), "yyyymmddhhmmss") & ".xlsx", _
　 fileformat:=xlWorkbookDefault
　　　　　　　　　End If
　　　　　　　End If
　　　　　　　.Close savechanges:=False
　　　　　End With
　　　Next
　End Sub
マクロがあるか無いかの判定は、
　 .HasVBProject
　これで行います。
　ただし、これは2007以降のプロパティですので、 2003以前では使用できません 。
　If Dir(strPath & strBook & ".xlsm") = "" Then
　If Dir(strPath & strBook & ".xlsx") = "" Then
　これらで、ファイルの存在確認をして、既に同名ファイルがある場合は日時を付けて保存します。
　Excel2003以前の形式ファイルを読み込んで、Excel2007以降の形式で保存する場合は、
　 fileformat:=
　この指定を正しくする必要があります。
　xlsxなら fileformat:=xlWorkbookDefault
　xlsmなら fileformat:=xlOpenXMLWorkbookMacroEnabled
　となります。
　まだまだ2003形式が多く残っていますが、いずれは2007以降形式に変換した方が良いでしょう。
　2007以降形式にした場合、何よりファイルサイズが小さくなるのが有難いですね。

ハイパーリンクからファイルのフルパスを取得する

　ハイパーリンクのリンク先ファイル情報を取得しようとすると、なかなか難しいことになります、
　ハイパーリンクからパスを取得すると相対パスとなり、簡単にはファイル情報を取得出来ません。
　以下のサンプルでは、ハイパーリンクの設定されているセルの右隣のセルに更新日時を出力しています。
　
Sub sample()
　　　Dim rng As Range
　　　Dim FileName As String
　　　Dim fso As New FileSystemObject
　 ChDir ThisWorkbook.Path
　　　For Each rng In ActiveSheet.UsedRange
　　　　　If rng.Hyperlinks.Count > 0 Then
　　　　　　　FileName = fso. GetAbsolutePathName (rng.Hyperlinks(1).Address)
　　　　　　　If fso.FileExists(FileName) Then
　　　　　　　　　rng.Offset(0, 1) = fso.GetFile(FileName). DateLastModified
　　　　　　　End If
　　　　　End If
　　　Next
　End Sub
※「ツール」→「参照設定」で、「Microsoft Scripting Runtime」にチェックを付けて下さい。
　参照設定しない場合は、
　 Dim fso As Object
　Set fso = CreateObject("Scripting.FileSystemObject")
　このようにしてください。
　 ChDir ThisWorkbook.Path
　事前にこれを行うことで、
　 GetAbsolutePathName
　これで絶対パスを取得できます。
　後は普通に、FSOで各種情報を取得してください。
　最初から ハイパーリンクを絶対パスで保存する方法 もあります。
　通常は、ハイパーリンクは相対パスで保存されますが、ファイルを移動したりすると、リンクが切れてしまいます、そこで、ハイパーリンクの起点を 変更して絶対パスで保存する方法になります。先日聞かれて、即答できませんでしたので、ここに覚書きの意味を含めて記載しておきます。
　設定をこれに変更した後に作成したハイパーリンクのみ絶対参照で保存されます。
　設定前に作成したハイパーリンクは相対パスのままになるので注意してください。
　一応、ハイパーリンクが絶対パスで保存されている場合の、
　上のノマロと同様の機能のVBAコードも掲載しておきます。
　
Sub sample2()
　　　Dim rng As Range
　　　Dim FileName As String
　　　For Each rng In ActiveSheet.UsedRange
　　　　　If rng.Hyperlinks.Count > 0 Then
　　　　　　　FileName = rng.Hyperlinks(1).Address
　　　　　　　If Dir (FileName) <> "" Then
　　　　　　　　　rng.Offset(0, 1) = FileDateTime (FileName)
　　　　　　　End If
　　　　　End If
　　　Next
　End Sub
こちらは、FSOを使うまでもないので、
　 Dir
　と
　 FileDateTime
　これで済ませています。

ボタンのテキスト名のシートへ移動（Application.Caller）

　メニューのシートを作成して、ボタンを配置、そしてボタンにより指定シートに移動する、
　よくありますが、ボタン一つずつに別々（移動先のシート毎に）のマクロを作成するのは面倒です、
　そこで、
　一つのマクロで済ませる方法の紹介です。
　
Sub sample()
　　　Sheets(ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text).Select
　End Sub
このマクロVBAなら、どのボタンでもボタンのテキストと同一のシートに移動出来ます。
　Application.Caller
　これで、クリックされたボタンを特定しています。
　ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
　これで、クリックされたボタンのテキストを取得しています。
　後は、SheetsのSelectだけです。
　注意点としては、
　ボタンのテキストと同一のシートが存在しない場合はエラーとなります。
　もっとも、最初に作るときだけしか発生しないエラーではありますが。
　メニューのシートを作成するときは、とても便利なはずです。
　ぜひ使ってみてください。

Excelの表をPowerPointへ図として貼り付け

　PowerPointを作っていると、エクセルの表を挿入したいことが多いです、
　単発作業なら手作業で十分ですが、
　定期的にやる場合や、数が多いと大変ですので、マクロで自動化したくなります。
　
Sub sample()
　　　Dim ppApp As New PowerPoint.Application
　　　Dim ppPt As Presentation
　　　Dim ppSlide As Slide
　　　Dim ppShape As PowerPoint.Shape
　　　Dim ws As Worksheet
　 'ppApp.Visible = True ' PowerPoint2007以前の場合は有効にしてください。
　　　Set ppPt = ppApp.Presentations.Open(ThisWorkbook.Path & "\sample.pptx")
　　　Set ws = ThisWorkbook.Worksheets("Sheet1")
　　　With ws
　　　　　.Range("A1").CurrentRegion.Copy
　 ' PasteSpeciaでエラーが出るときは、ここに待ちを作ります。
　 'スライド番号を指定
　　　　　Set ppSlide = ppPt.Slides(1)
　　　　　ppSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse
　　　　　Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)
　 '上位置
　　　　　ppShape.Top = Application.CentimetersToPoints(1)
　 '左位置
　　　　　ppShape.Left = Application.CentimetersToPoints(1)
　 '縦横比を固定
　　　　　ppShape.LockAspectRatio = msoTrue
　 '横幅
　　　　　ppShape.Width = Application.CentimetersToPoints(30)
　　　　　Application.CutCopyMode = False
　　　End With
　　　ppPt.Save
　　　ppApp.Quit
　　　Set ppPt = Nothing
　　　Set ppApp = Nothing
　End Sub
上記は、まずは最低限のコードです。
　セル範囲をコピーして、拡張メタファイルとして貼り付けています。
　エラー処理は入れていませんので、適宜入れて下さい。
　良く発生するエラーについては、下で説明を書きました。
　 PasteSpecial
　この部分の指定は、
　
DataType PpPasteDataType クリップボードの内容をドキュメントに挿入するときの形式です。
　既定値は、クリップボードの内容によって異なります。
　クリップボードの内容が引数 DataType で指定したデータ型がサポートされていない場合、エラーが発生します。
　DataTypeには以下が指定可能です。
　ppPasteBitmap
　ppPasteDefault
　ppPasteEnhancedMetafile
　ppPasteHTML
　ppPasteGIF
　ppPasteJPG
　ppPasteMetafilePicture
　ppPastePNG
　ppPasteShape
DisplayAsIcon MsoTriState 埋め込みオブジェクトまたはリンクをアイコンで表示するには、MsoTrue?を設定します。
IconFileName 文字列型 (String) 引数 DisplayAsIcon が定数?msoTrue?に設定されている場合、この引数は表示するアイコンが保存されているファイルのパスとファイル名となります。
　引数 DisplayAsIcon が定数?msoFalse?に設定されている場合、この引数は無視されます。
IconIndex 長整数型 (Long) DisplayAsIcon がmsoTrueに設定されている場合この引数は IconFilename で指定されるプログラム ファイルで使用するアイコンに対応する番号です。
　たとえば、0 (ゼロ) は最初のアイコンに対応して 1、2 番目のアイコンに対応します。この引数を省略すると、最初の (既定の) アイコンが使用されます。
　DisplayAsIcon がmsoFalseに設定されている場合、この引数は無視されます。IconIndex が有効な範囲外にある場合は、既定のアイコン (インデックス 0) が使用されます。
IconLabel 文字列型 (String) 引数 DisplayAsIcon が定数?msoTrue?に設定されている場合、この引数はアイコンの下に表示されるテキストとなります。
　このラベルがない場合、クリップボードの内容に基づいてアイコン ラベルが作成されます。
　引数 DisplayAsIcon が定数?msoFalse?に設定されている場合、この引数は無視されます。
Link MsoTriState クリップボード内容のソース ファイルへのリンクを作成するかどうかを指定します。クリップボードの内容がリンクをサポートしていない場合、エラーが発生します
ほとんどの場合、上記のコードで問題ないのですが、
　Excelの表が大きかったり、情報が複雑な場合、
　PasteSpecialでエラーとなる場合があります。
　エラーの発生理由は、
　Copyが非同期で行われているらしいことが原因です。
　そこで、対策としては、Copyの直後に一定時間待ちを作ることです。
　まず最初には、
　DoEvents
　これで試してみて下さい、これで解決するならこれが一番です。
　これでダメなら、
　Application.Wait
　で1秒程度の待ちを作って下さい。
　APIのSleepなら、ms単位で調整できます。
　実際のプログラムでは、この貼り付けが複数になり、
　かつ、サイズ等もそれぞれ指定する必要がありますので、
　結構複雑なコードを書くことになります。
　このような貼り付け情報を別シートに表にしておき、
　それを基に貼り付けるようにする必要があります。

方眼紙Excelが楽に入力できるVBA

　もはや、「いじめ」か「いたずら」、
　方眼紙Excelに、1枠1文字を入れろと言われて、悪戦苦闘・・・
　マクロ書けば、こんな「いじめ」も「いたずら」も、サクッと克服できます。
　以下のような、セル結合の鬼と化したExcelに、
　罫線で囲んだ枠内に、1枠1文字で入れるという苦行を、マクロならサクッと解決できます。
　 方眼紙Excelのサンプル
　 2行2列をセル結合して、1枠にしています。
　 マクロVBAのコード
　 シートモジュール に、以下を全部貼り付けて下さい。
　
Option Explicit
　 'Changeイベント
　Private Sub Worksheet_Change(ByVal Target As Range)
　　　Dim sRng As Range '開始セル
　　　Dim cRng As Range '処理中セル
　　　Dim nRng As Range '次のセル
　　　Dim strIn As String '入力文字
　 '入力された先頭セルに限定
　　　Set sRng = Target.Item(1)
　 '空欄なら無視
　　　If IsEmpty(sRng) Then
　　　　　Exit Sub
　　　End If
　 '結合範囲を取得
　　　Set cRng = sRng.MergeArea
　 '入力文字
　　　strIn = sRng.Value
　 'イベント停止
　　　Application.EnableEvents = False
　 '文字を全て配置したか、方眼紙の枠がなくなるまで
　　　Do
　 '文字を全て配置が終わった
　　　　　If Len(strIn) = 0 Then
　　　　　　　Exit Do
　　　　　End If
　 '次の方眼紙の枠を取得、無ければ残りの文字を入れる
　　　　　Set nRng = getNext(cRng)
　　　　　If nRng Is Nothing Then
　　　　　　　cRng.Value = strIn
　　　　　　　Exit Do
　　　　　End If
　 '左の1文字を入れる
　　　　　cRng.Value = Left(strIn, 1)
　 '文字を2文字目からに
　　　　　strIn = Mid(strIn, 2)
　 '次の方眼紙の枠のセルを次のセルに
　　　　　Set cRng = nRng
　　　Loop
　 'イベント再開
　　　Application.EnableEvents = True
　End Sub
　 '方眼紙の枠のセルか判定
　Private Function isGraph(ByVal rng As Range) As Boolean
　 '四隅に罫線が引かれている場合に、方眼紙の枠と判定
　　　If rng.Borders(xlEdgeTop).LineStyle <> xlNone And _
　　　　　rng.Borders(xlEdgeBottom).LineStyle <> xlNone And _
　　　　　rng.Borders(xlEdgeLeft).LineStyle <> xlNone And _
　　　　　rng.Borders(xlEdgeRight).LineStyle <> xlNone Then
　　　　　isGraph = True
　　　Else
　　　　　isGraph = False
　　　End If
　End Function
　 '次の方眼紙の枠を取得
　Private Function getNext(ByVal cRng As Range) As Range
　　　Dim rng As Range
　　　Dim nRng As Range
　 '右のセルが方眼紙の枠なら、それを設定
　　　If isGraph(cRng.Offset(, 1).MergeArea) = True Then
　　　　　Set getNext = cRng.Offset(, 1)
　　　　　Exit Function
　　　End If
　 '右のセルが方眼紙の枠以外の時は、下のセルを判定
　　　Set rng = cRng.Offset(1).MergeArea
　 '下のセルが方眼紙の枠でなければ終わり
　　　If isGraph(rng) = False Then
　　　　　Set getNext = Nothing
　　　　　Exit Function
　　　End If
　 '左に向かって先頭列の方眼紙の枠を探す
　　　Do
　 'A列なら終わり
　　　　　If rng.Column = 1 Then
　　　　　　　Set getNext = rng
　　　　　　　Exit Function
　　　　　End If
　 '左が方眼紙の枠でなければ終わり
　　　　　If isGraph(rng.Offset(, -1).MergeArea) = False Then
　　　　　　　Set getNext = rng
　　　　　　　Exit Function
　　　　　End If
　 '次の行の先頭の方眼紙の枠セル
　　　　　Set rng = rng.Offset(, -1).MergeArea
　　　Loop
　End Function
コードの解説は、コメントに入れてありますので参考にしてください。
　気を付けるべき点は、
　常に、.MergeAreaでRangeを指定することと、
　次のセルに進む時には、.Offsetを使うということです。
　.Offsetを使えば、結合セルの次が簡単に取得できます。
　Cellsで行・列指定していたら、かなり大変なコードになってしまいます。
　入力開始セルを選択して、文字を全部入れて下さい。
　どこから書き始めても、ちゃんと次の行にもすすんで、1枠1文字になります。
　ただし、以下の制限があります。
　 制限事項
　・方眼紙の枠の判定は、上下左右に罫線が引かれていること
　・複数行（多段）の場合は、列の凸凹にならないように、全行が同列数にしてください。
　・文字が入りきらない場合は、最後のセルに残りの文字を全て入れます。
　 入力した結果
　先頭セルに、
　 「もはや、「いじめ」か「いたずら」、方眼紙Excelに、1枠1文字を入れろと言われて、悪戦苦闘・・・」
　と入れると、
　 最後は、はいりきらないので、・・が1枠に入っています。
　ここに掲載したものは、あくまでサンプルですので、
　複雑な形（列数が違うとか、途中から別項目になっているとか）であれば、
　さらにマクロVBAの記述を追加していくことになります。
　また、
　分割された文字を、簡単にまとめたい場合もあるでしょう。
　分割よりは結合する方が簡単なので、チャレンジしてみて下さい。
　 要点は、次のセルを見つける部分 です。
　Function getNext
　ここを工夫すれば、複雑なパターンにもある程度は対応できるVBAを作ることが出来ます。

画像のトリミング（PictureFormat,Crop）

　エクセルで画像をトリミングするマクロになります、
　画像の一部を四角に切り取るVBAコードの解説です。
　図形で切り取る等は、自動記録のコードをほぼそのまま使えるはずですので、
　ここでは、基本的かつ汎用的な、一部を四角に切り取るVBAコードについて、
　サンプルコードを掲載して解説します。
　 画像の一部を四角にトリミング
　
Sub TrimPicture()
　　　Const OffTop As Double = 100 '上の切り取り
　　　Const OffLeft As Double = 150 '左の切り取り
　　　Const OffBottom As Double = 400 '下の切り取り
　　　Const OffRight As Double = 600 '右の切り取り
　　　Dim ws As Worksheet
　　　Dim sp1 As Shape
　　　Set ws = ActiveSheet
　　　Set sp1 = ws.Shapes(1)
　　　With sp1
　　　　　.PictureFormat.CropTop = OffTop
　　　　　.PictureFormat.CropLeft = OffLeft
　　　　　.PictureFormat.CropBottom = OffBottom
　　　　　.PictureFormat.CropRight = OffRight
　　　End With
　End Sub

　 VBAコードは見た通りですので、特に解説は必用ないと思います。
　気を付けて頂きたいのは、 画像自体は元の画像がそのまま残っている という事です。
　従って、次のサンプルコードで 元に戻すことが出来ます 。
　ファイルサイズが問題にならないのなら、
　このトリミングのVBA実行したままでも問題はありません。
　 トリミングされた画像をもとに戻す
　
Sub UndoPicture()
　　　Dim ws As Worksheet
　　　Dim sp1 As Shape
　　　Set ws = ActiveSheet
　　　Set sp1 = ws.Shapes(1)
　　　With sp1.PictureFormat
　　　　　.CropLeft = 0
　　　　　.CropRight = 0
　　　　　.CropTop = 0
　　　　　.CropBottom = 0
　　　End With
　End Sub
トリミング位置を全て0に戻すことで、
　トリミング前に戻すことが出来ます。
　 画像の一部を四角にトリミングし、貼り付けし直す
　
Sub TrimPictureAndPaste()
　　　Const OffTop As Double = 56
　　　Const OffLeft As Double = 133
　　　Const OffBottm As Double = 464
　　　Const OffRight As Double = 569
　　　Dim ws As Worksheet
　　　Dim sp1 As Shape
　　　Dim sp2 As Shape
　　　Set ws = ActiveSheet
　　　Set sp1 = ws.Shapes(1)
　　　With sp1
　　　　　.PictureFormat.CropTop = OffTop
　　　　　.PictureFormat.CropLeft = OffLeft
　　　　　.PictureFormat.CropBottom = OffBottm
　　　　　.PictureFormat.CropRight = OffRight
　　　　　.Copy
　　　　　ws.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
　　　　　Set sp2 = ws.Shapes(ws.Shapes.Count)
　　　　　sp2.Top = .Top
　　　　　sp2.Left = .Left
　　　　　.Delete
　　　End With
　End Sub
最初に紹介したコード、 TrimPictureを実行後 に、
　 トリミング後の画像をコピー し、
　 元の画像位置に形式を選択して貼り付け 、
　最後に、 元の画像を削除 しています。
　画像を、形式を選択して貼り付けしていますので、
　トリミング前に戻すことはできません。
　画像サイズは小さくなりますので、
　Excelファイルが気になる場合に有効です。
　マクロで画像をトリミングする事が必要になることは滅多ににないとは思います。
　しかし、例えば、
　画面キャプチャをマクロで取った場合に、不要な範囲を取り除きたいといった場合には、
　今回のVBAコードが使えるはずです。

CSVの読み込み方法（改の改）

　CSVのマクロVBAでの読込方法については複数の記事を掲載しており、人気記事として多くのアクセスがあります。
　掲載しているVBAコードは汎用的に書いてあり、ほぼそのまま使用できるものです。
　しかし、
　CSVは多くの形式（区切り文字、文字コード等）があり、今まで掲載したコードでは解決出来ないものがあります。
　そこで、今回は今まで対応していなかった形式も含めて、
　通常考えられる形式を全て処理可能なコードを提示します。

CSVの形式について

区切り文字
　 カンマ区切り
　 C omma S eparated V alues
　ファイルの拡張子は csv
　 タブ区切り
　 T ab S eparated V alues
　ファイルの拡張子は tsv または csv
　狭義でのCSVは、もちろんカンマ区切りですが、
　拡張子がcsvでタブ区切りのファイルも結構存在しており、Excelでは普通に開くことが出来ます。
　拡張子のcsvがExcelに標準で紐ついていて、Excelがタブ区切りも読めるので、
　本来ならtsvなのでしょうが、拡張子がcsvとなっているタブ区切りも多く存在します。
　 文字コード
　 Shit-JIS
　Windowsでは標準ともいえる文字コードです。
　Windowsで作成したcsvなら、ほとんどがShit-Jisでしよう。
　メモ帳で保存時には、「ANSI」になります。
　 UTF-8
　BOM付きとBOM無しがあります。
　BOM無しはUTF-8Nと言われたりしますが、ここでは呼び方よりも
　 Unicode
　文字コードというより、文字集合と言った方が正しいのかもしれませんが、
　ここでは、
　UTF-16
　と認識していただければ良いでしょう。
　 Unicode big endian
　Unicodeには、複数バイトで構成されるデータの並べ方で、エンディアンというものがあり、
　ビッグエンディアンとリトルエンディアンがある。
　メモ帳でも保存時の、
　「Unicode」は、リトルエンディアン
　「Unicode big endian」は、ビッグエンディアン
　結果として、上記の区切り文字と文字コードの組み合わせが存在することになります。
　全ての組み合わせで処理可能なVBAコードを作ることが目的です。
　 CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…
　これらのページで掲載しているVBAコードを改造し、
　テキストの文字コードを判定を加えたものです。
　 ※UTF-8N（BOMなし）は文字コードの自動判別が完全には対応できません。
　UTF-8Nのcsvを読み込むときには、
　下記使用例のように、OptionのCharSetに"utf-8"または"utf-8n"を指定してください。

CSV読み込みVBAコード


　
Option Explicit
　 '使用例
　Sub sample1()
　　　Dim ws As Worksheet
　　　Dim sFile As String
　 'csvファイルを指定
　　　sFile = "csvのフルパス"
　 '出力シート
　　　Set ws = ActiveSheet
　　　ws.Cells.Clear
　 '以下では全列を文字に設定
　 '数値も文字としてセルに入ります
　 '文字設定にしなければ数値は数値として入ります。
　　　ws.Cells.NumberFormatLocal = "@"
　　　Application.ScreenUpdating = False
　 'CSV取込
　　　Call CsvInText(ws, sFile)
　 'utf-8決め打ちで読み込む場合は以下で
　 'Call CsvInText(ws, sFile, "utf-8")
　　　Application.ScreenUpdating = True
　End Sub
　Sub CsvInText(ByVal ws As Worksheet, _
　　　　　　　　ByVal strFile As String, _
　　　　　　　　Optional ByVal CharSet As String = "Auto")
　　　Dim strRec As String
　　　Dim i As Long, j As Long, k As Long
　　　Dim lngQuate As Long
　　　Dim strCell As String
　　　Dim blnCrLf As Boolean
　 '文字コードを自動判別し、全行をCrLf区切りに統一してStringに入れる
　　　strRec = readCsv(strFile, CharSet)
　　　i = 1 'シートの1行目から出力
　　　j = 0 '列位置はPutCellでカウントアップ
　　　lngQuate = 0 'ダブルクォーテーションの数
　　　strCell = ""
　　　For k = 1 To Len(strRec)
　　　　　Select Case Mid(strRec, k, 1)
　　　　　　　Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　blnCrLf = False
　　　　　　　　　　　If k > 1 Then '改行のCrLfはCrで改行判定済なので無視する
　　　　　　　　　　　　　If Mid(strRec, k - 1, 2) = vbCrLf Then
　　　　　　　　　　　　　　　blnCrLf = True
　　　　　　　　　　　　　End If
　　　　　　　　　　　End If
　　　　　　　　　　　If blnCrLf = False Then
　　　　　　　　　　　　　Call PutCell(ws, i, j, strCell, lngQuate)
　　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　　j = 0
　　　　　　　　　　　　　lngQuate = 0
　　　　　　　　　　　　　strCell = ""
　　　　　　　　　　　End If
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case ",", vbTab '「"」が偶数なら区切り、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　Call PutCell(ws, i, j, strCell, lngQuate)
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case """" '「"」のカウントをとる
　　　　　　　　　lngQuate = lngQuate + 1
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　Case Else
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　End Select
　　　Next
　 '最終列の処理
　　　If j > 0 And strCell <> "" Then
　　　　　Call PutCell(ws, i, j, strCell, lngQuate)
　　　End If
　End Sub
　 '1フィールドごとにセルに出力
　Sub PutCell(ByVal ws As Worksheet, _
　　　　　　　ByRef i As Long, ByRef j As Long, _
　　　　　　　ByRef strCell As String, _
　　　　　　　ByRef lngQuate As Long)
　　　j = j + 1
　 '「""」を「"」で置換
　　　strCell = Replace(strCell, """""", """")
　 '前後の「"」を削除
　　　If Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
　　　　　If Len(strCell) <= 2 Then
　　　　　　　strCell = ""
　　　　　Else
　　　　　　　strCell = Mid(strCell, 2, Len(strCell) - 2)
　　　　　End If
　　　End If
　　　ws.Cells(i, j) = strCell
　　　strCell = ""
　　　lngQuate = 0
　End Sub
　 '文字コードを自動判別し、全行をCrLf区切りに統一してStringに入れる
　Function readCsv(ByVal strFile As String, _
　　　　　　　　　 ByVal CharSet As String) As String
　　　Dim objFSO As New FileSystemObject
　　　Dim inTS As TextStream
　　　Dim adoSt As New ADODB.Stream
　　　Dim strRec As String
　　　Dim i As Long
　　　Dim aryRec() As String
　　　If CharSet = "Auto" Then CharSet = getCharSet(CStr(strFile))
　　　Select Case LCase(CharSet)
　　　　　Case "unicode", "unicodefeff"
　 'TristateTrueで読込
　　　　　　　Set inTS = objFSO.OpenTextFile(CStr(strFile), ForReading, , TristateTrue)
　　　　　　　strRec = inTS.ReadAll
　　　　　Case "utf-8", "utf-8n"
　 'ADOを使って読込、その後の処理を統一するため全レコードをCrLfで結合
　　　　　　　With adoSt
　　　　　　　　　.Type = adTypeText
　　　　　　　　　.CharSet = "UTF-8"
　　　　　　　　　.Open
　　　　　　　　　.LoadFromFile strFile
　　　　　　　　　i = 0
　　　　　　　　　Do While Not (.EOS)
　　　　　　　　　　　ReDim Preserve aryRec(i)
　　　　　　　　　　　aryRec(i) = .ReadText(adReadLine)
　　　　　　　　　　　i = i + 1
　　　　　　　　　Loop
　　　　　　　　　.Close
　　　　　　　　　strRec = Join(aryRec, vbCrLf)
　　　　　　　End With
　　　　　Case Else
　　　　　　　Set inTS = objFSO.OpenTextFile(CStr(strFile), ForReading)
　　　　　　　strRec = inTS.ReadAll
　　　End Select
　　　Set inTS = Nothing
　　　Set objFSO = Nothing
　　　readCsv = strRec
　End Function
　 '文字コードの自動判別
　 'UTF-8のBOMなしは文字コードの判別に対応できていません。
　Function getCharSet(ByVal sFile As String) As String
　　　Dim objHtml As MSHTML.HTMLDocument
　　　Dim strRec As String
　 'GetObjectでHTMLDocumentを生成し、文字コードを判定する
　　　Set objHtml = GetObject(sFile, "htmlfile")
　　　Do While objHtml.readyState <> "complete"
　　　　　DoEvents
　　　Loop
　　　getCharSet = objHtml.CharSet
　　　Set objHtml = Nothing
　End Function
参照設定
　Microsoft Scripting Runtime
　Microsoft ActiveX Data Objects x.x Library
　Microsoft Html Object Library
　 文字コード処理について
　文字コードの判別については、 GetObject関数 でhtmlfileを作成しCharSetで判定しています。
　ActiveXコンポーネントから提供されたオブジェクトの参照を返します。ファイルパス（フルパスと名前）からオブジェクトの参照を作成した り、既に起動中のオブジェクトを取得する際に使用します。GetObject関数の構文 GetObject([pathname],[class]) pathname 省略可能。
　文字コードによって、
　FileSystemObject.OpenTextFile
　ADODB.Stream
　どちらで読み込むかを振り分けています。
　VBAコード全体については解説しきれませんので、VBAコード内コメントを頼りに読み進めてください。
　区切り文字と文字コードの主要な組み合わせについては、
　テストデータを作成して確認しましたが、漏れがあるかもしれません。
　VBA開発で実際に使う事もあるので、気が付いた時点で修正します。
　また、上手く動かない等に気づいたときにご一報をいただければ修正します。

配列を使ってシートにまとめて出力する場合

上記のマクロVBAでは、1フィールドごとにセルに出力しています。
　これは明らかに処理速度が遅くなってしまいます。
　（数万件くらいまでなら、そもそもそんなに時間もかかりませんが）
　ここは、一旦配列に入れておいて、最後にまとめてシートに出力したいところです。
　なのですが、
　世の中には、お行儀のよいCSVばかりではありません。
　行によって列数（つまりカンマの区切り数）が不定となっているようなものもあったりします。
　先頭行は10列ではじまっているのに、途中から12列になっていたりという事です。
　このようなCSVにおいては列数を事前に決められない為、配列を用意するのが難しくなります。
　これらに対応するには、列数を多めにとった配列を用意するか、
　一旦ジャグ配列（要素も配列である配列）として確保して、最後に2次元配列に入れ直してからシートに出力する等の工夫が必要です。
　・列数が決まっていれば、その列数で配列を用意
　・列数不明の時は、1行目の列数取得後に配列を用意
　・列数不定の場合は、ジャグ配列で処理
　以上のどれかで対応することになります。
　下に行くにしたがって、VBAの難易度は上がっていきます。
　上記VBAの主な変更点は、
　・CsvInTextで配列を用意
　・PutCellの
　　ws.Cells(i, j) = strCell
　　このws.Cells(i, j)を配列に変更
　固定列数であれば、そんなに多くの修正は必要ないと思います。
　配列の行数は最初は少し大きめに確保しておいて、行数が足らなくなったらRedim Preserveで確保すれば良いでしょう。
　このような面倒な処理の必要性がないのは、シートのセルを直接利用する最大の利点ともいえます。
　興味のある方は、ぜひ配列化にチャレンジしてみてください。
　要望があり機会があれば、当サイトでも公開しようと思います。
　・・・
　という事で、作成しました。
　 CSVの読み込み方法（ジャグ配列）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。当初作成して以来、ご要望をいただいたり自身で 使っている中で、対応できないCSVが出てくるたびに改良を重ねています。今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。

QueryTablesを使ったCSV読み込みVBAコード

Unicode big endian の対応が必要ないのであれば、
　以下の QueryTables を使った簡単なコードで対応できます。
　
Sub sample2()
　　　Dim ws As Worksheet
　　　Dim sFile As String
　　　sFile = "パス\test.csv"
　　　Set ws = Worksheets("Sheet1")
　　　ws.Cells.Clear
　　　ws.Cells.NumberFormatLocal = "@"
　　　Call CsvInQuery(ws, sFile)
　End Sub
　Sub CsvInQuery(ByVal ws As Worksheet, ByVal sFile As String)
　　　Dim cArray() As Integer
　　　Dim i As Long
　　　ReDim cArray(255)
　　　For i = 0 To 255
　　　　　cArray(i) = XlColumnDataType.xlTextFormat
　　　Next
　　　With ws.QueryTables.Add(Connection:="TEXT;" & sFile, Destination:=ws.Range("$A$1"))
　　　　　.TextFileTabDelimiter = True
　　　　　.TextFileCommaDelimiter = True
　　　　　.TextFileColumnDataTypes = cArray
　　　　　Select Case LCase(getCharSet(CStr(sFile)))
　　　　　　　Case "utf-8", "unicode", "unicodefeff"
　　　　　　　　　.TextFilePlatform = 65001
　　　　　　　Case Else
　　　　　　　　　.TextFilePlatform = 932
　　　　　End Select
　　　　　.Refresh BackgroundQuery:=False
　　　　　.Delete
　　　End With
　End Sub
　Function getCharSet(ByVal sFile As String) As String
　　　Dim objHtml As MSHTML.HTMLDocument
　　　Set objHtml = GetObject(sFile, "htmlfile")
　　　Do While objHtml.readyState <> "complete"
　　　　　DoEvents
　　　Loop
　　　getCharSet = objHtml.charSet
　　　Set objHtml = Nothing
　End Function
要点としては、
　TextFileColumnDataTypes
　ここには、実際のカラム数以上を指定しても問題ありません。
　上記では、256列全てを文字列指定にしています。
　また、区切り文字として、カンマとタブを指定しておくことで、どちらにも対応できます。
　これにより、VBAコードを変更することなく、上記のコードでほとんどのCSVを処理可能としています。
　ただし、 Unicode big endian については、QueryTablesは対応できません。
　本記事は、私自身の備忘録も兼ねています。
　VBA開発時には、CSV読込の雛形コードとして使えるようにする意味もあり、ここに掲載しました。

数式の参照しているセルを取得する

　セルに入っている数式の参照しているセルを取得するには、
　RangeのPrecedentsプロパティを使いますが、このプロパティは他のシートの参照には対応していません。
　また、セルの参照先を取得するプロパティには、 Dependents プロパティがあります。
　 Precedents
　セルが直接または間接に参照している参照元を表すRangeオブジェクトを返します
　 A1セルに=B1 と入っている場合に、 A1セルのPrecedentsでB1セルを取得 できます。
　 Dependents
　セルを直接または間接に参照している参照先Rangeオブジェクトを返します
　 A1セルに=B1 と入っている場合に、 B1セルのDependentsでA1セルを取得 できます。
　 Precedents も Dependents も、どちらも他のシートの参照には対応していません。
　そこで、以下のサンプルコードでは、
　指定のセルの数式が参照している（参照元）セルを配列で返します。
　
Function getFormulaRange(ByVal argRange As Range) As Range()
　　　Dim sFormula As String
　　　Dim aryRange() As Range
　　　Dim tRange As Range
　　　Dim ix As Long
　　　Dim i As Long
　　　Dim flgS As Boolean 'シングルクオートが奇数の時True
　　　Dim flgD As Boolean 'ダブルクオートが奇数の時True
　　　Dim sSplit() As String
　　　Dim sTemp As String
　 '=以降の計算式
　　　sFormula = Mid(argRange.FormulaLocal, 2)
　 '計算式の中の改行や余分な空白を除去
　　　sFormula = Replace(sFormula, vbCrLf, "")
　　　sFormula = Replace(sFormula, vbLf, "")
　　　sFormula = Trim(sFormula)
　　　flgS = False
　　　flgD = False
　　　For i = 1 To Len(sFormula)
　 'シングル・ダブルのTrue,Falseを反転
　　　　　Select Case Mid(sFormula, i, 1)
　　　　　　　Case "'"
　　　　　　　　　flgS = Not flgS
　　　　　　　Case """"
　 'シングルの中ならシート名
　　　　　　　　　If Not flgS Then
　　　　　　　　　　　flgD = Not flgD
　　　　　　　　　End If
　　　　　End Select
　　　　　Select Case Mid(sFormula, i, 1)
　 '各種演算子の判定
　　　　　　　Case "+", "-", "*", "/", "^", ">", "<", "=", "(", ")", "&", ",", " "
　　　　　　　　　Select Case True
　　　　　　　　　　　Case flgS
　 'シングルの中ならシート名
　　　　　　　　　　　　　sTemp = sTemp & Mid(sFormula, i, 1)
　　　　　　　　　　　Case flgD
　 'ダブルの中なら無視
　　　　　　　　　　　Case Else
　 '各種演算子をvbLfに置換
　　　　　　　　　　　　　sTemp = sTemp & vbLf
　　　　　　　　　End Select
　　　　　　　Case Else
　 'ダブルの中なら無視、ただしシングルの中はシート名
　　　　　　　　　If Not flgD Or flgS Then
　　　　　　　　　　　sTemp = sTemp & Mid(sFormula, i, 1)
　　　　　　　　　End If
　　　　　End Select
　　　Next
　　　On Error Resume Next
　 'vbLfで区切って配列化
　　　sSplit = Split(sTemp, vbLf)
　　　ix = 0
　　　For i = 0 To UBound(sSplit)
　　　　　If sSplit(i) <> "" Then
　　　　　　　Err.Clear
　 'Application.Evaluateメソッドを使ってRangeに変換
　　　　　　　If InStr(sSplit(i), "!") > 0 Then
　　　　　　　　　Set tRange = Evaluate(Trim(sSplit(i)))
　　　　　　　Else
　 'シート名を含まない場合は、元セルのシート名を付加
　　　　　　　　　Set tRange = Evaluate("'" & argRange.Parent.Name & "'!" & Trim(sSplit(i)))
　　　　　　　End If
　 'Rangeオブジェクト化が成功すれば配列へ入れる
　　　　　　　If Err.Number = 0 Then
　　　　　　　　　ReDim Preserve aryRange(ix)
　　　　　　　　　Set aryRange(ix) = tRange
　　　　　　　　　ix = ix + 1
　　　　　　　End If
　　　　　End If
　　　Next
　　　On Error GoTo 0
　　　getFormulaRange = aryRange
　End Function
使い方としては、以下のようになります。
　
Sub sample()
　　　Dim aryRange() As Range
　　　Dim var As Variant
　　　aryRange = getFormulaRange(Range("A1"))
　　　For Each var In aryRange
　　　　　Debug.Print var.Address(External:=True)
　　　Next
　End Sub
イミディエイト ウインドウに、参照しているセルのアドレスが表示されます。
　A1=TRIM(B$1&'S&h"e ''et2'!$A1)*Sheet1!$C$1+SUM('S&h"e''et2'!A1:C1,B1)
　この場合は、イミディエイト ウインドウには、
　[ブック名]Sheet1!$B$1
　'[ブック名]S&h"e ''et2'!$A$1
　[ブック名]Sheet1!$C$1
　'[ブック名]S&h"e ''et2'!$A$1:$C$1
　[ブック名]Sheet1!$B$1
　このように表示されます。
　 Precedents や Dependents と組み合わせて使用する場合は、
　For Each var In aryRange
　この中で、
　var.ParentとRange("A1").Parentが同じであれば同じシート内なので、
　 Precedents や Dependents で取得済と判定すれば良いでしょう。
　滅多に必要となることもないと思いますが、
　いざ必要となった時に、VBAを最初から書くのは大変なので、そのような場合に思い出してください。

フォルダ（サブフォルダも全て）削除する、Optionでファイルのみ削除

　VBAでフォルダを削除するにはRmDirステートメントを使いますが、
　サブフォルダやファイルが入っている場合は、RmDirはエラーとなります、
　そこで、サブフォルダやファイルがある場合は、FileSystemObjectを使います。
　以下のサンプル使用時には、
　「ツール」→「参照設定」で、「Microsoft Scripting Runtime」にチェックを付けてください。
　参照設定しない場合は、
　Dim objFSO As Object
　Set objFSO = CreateObject("Scripting.FileSystemObject")
　のように書き直してください。
　
Sub sample2()
　　　Dim objFSO As New FileSystemObject
　　　objFSO.DeleteFolder "フォルダのフルパス"
　　　Set objFSO = Nothing
　End Sub
これで、サブフォルダもファイルも、一括で全て削除できます。
　この場合の問題点としては、
　・一つでも削除できないファイルがあるとエラーとなる
　・サブフォルダのどれかがエクスプローラー等で開かれているとエラーとなる
　等々、結構削除できない場合が発生します。
　また、フォルダは消さずにサブフォルダ内も含めて全てのファイルを削除するといった事が出来ません。
　そこでも独自にフォルダ削除を作成し、もう少し融通の利くフォルダ削除を作成してみました。
　最下層からファィルを削除してからフォルダ削除を順次行うVBAになります。
　
'**********************************************************************
　 ' sDir : 対象フォルダ
　 ' sMsg : エラー発生時のメッセージ保存
　 ' isOnlyFile : ファイルのみ削除する場合にTrue
　 '**********************************************************************
　Function DelDir(ByVal sDir As String, _
　　　　　　　　　ByRef sMsg As String, _
　　　　　　　　　Optional ByVal isOnlyFile As Boolean = False) _
　　　　　　　　　As Boolean
　　　Dim objFSO As New FileSystemObject
　　　Dim objFolder As Folder
　　　sMsg = ""
　　　If Not objFSO.FolderExists(sDir) Then
　　　　　sMsg = "指定のフォルダは存在しません。"
　　　　　DelDir = False
　　　　　Exit Function
　　　End If
　　　Set objFolder = objFSO.GetFolder(sDir)
　　　Call DelDirectorys(objFolder, isOnlyFile, sMsg)
　　　If sMsg = "" Then
　　　　　DelDir = True
　　　Else
　　　　　DelDir = False
　　　End If
　End Function
　Sub DelDirectorys(ByVal objFolder As Folder, _
　　　　　　　　　　　ByVal isOnlyFile As Boolean, _
　　　　　　　　　　　ByRef sMsg As String)
　　　Dim objFolderSub As Folder
　　　Dim objFile As File
　　　On Error Resume Next
　　　For Each objFolderSub In objFolder.SubFolders
　　　　　Call DelDirectorys(objFolderSub, isOnlyFile, sMsg)
　　　Next
　　　For Each objFile In objFolder.Files
　　　　　objFile.Delete
　　　　　If Err.Number <> 0 Then
　　　　　　　sMsg = sMsg & "ファイル「" & objFile.Path & "」が削除できませんでした" & vbLf
　　　　　　　Err.Clear
　　　　　End If
　　　Next
　　　If Not isOnlyFile Then
　　　　　objFolder.Delete
　　　　　If Err.Number <> 0 Then
　　　　　　　sMsg = sMsg & "フォルダ「" & objFolder.Path & "」が削除できませんでした" & vbLf
　　　　　　　Err.Clear
　　　　　End If
　　　End If
　　　Set objFolderSub = Nothing
　　　Set objFile = Nothing
　　　On Error GoTo 0
　End Sub
削除できないものがあっても、それは無視して次の削除を行うために、
　エラー処理として、
　On Error Resume Next
　を組み込んでいます。
　削除できなかったフォルダおよびファイルがあった場合は、
　変数sMsgにその旨のメッセージを入れています。
　使い方としては、以下のようになります。
　
Sub sample()
　　　Dim sMsg As String
　　　If DelDir(ThisWorkbook.Path & "\test", sMsg) Then
　　　　　MsgBox "削除終了"
　　　Else
　　　　　MsgBox sMsg
　　　End If
　End Sub
ファイルのみ削除 する場合は、
　 DelDir(ThisWorkbook.Path & "\test", sMsg , True )
　として下さい。
　使用するプロシージャーで、既にFileSystemObjectを生成していている場合は、
　DelDirectorys
　こちらを直接使ってもいでしょう。
　このようなVBAコードが実際に必要になることは、そう多くは無いと思います。
　いざという時の雛形として、またVBAの勉強用のサンプルとしてお使いください。

オセロを作りながらマクロVBAを学ぼう

　ExcelマクロVBAでオセロ（リバーシ）を作っていきながら、マクロVBAを学んで行きましょう。
　 目的 は、 マクロVBAの学習 であり、思考を整理しVBAでプログラミングする学習です。
　従って、強いソフトを作ることが目的ではありませんので、
　最近流行のAIなんちゃら・・・なんていうのは考えるつもりはありません。
　あくまで、マクロVBAの学習素材としてオセロを作成するという事です。
　そして、マクロVBAを学習するとは、プログラミングの学習です。
　プログラミングで最も重要な事は、思考を論理的に整理し、それをプログラミング言語に表すという事にあります。
　本記事では、この点に重点を置いて書き進めます。
　従って、マクロVBAの記述自体は、本サイト内の他のページで解説しているものがほとんどになります。
　・石を置ける場所とは
　・自分の石で相手の石を挟むとは
　これらを、しっかりと文章化できなければ、VBAでプログラミングすることはできません。
　本記事では、このような事を、
　 ・論理的に整理
　・文章化
　・マクロVBAでのプログラミング
　このように進めて行きます。
　マクロVBAの記述方法やテクニックはあまた解説されています。
　しかし、それらを読んでもなかなか実際にプログラミング出来ないものです。
　それは、
　論理的に整理し文章化することが出来ていないからなのです。
　本記事の最大の目的は、論理的思考と文章化にあります。
　とはいえ、
　出来れば少しでも強いソフトが作成できればそれに越したことはありませんので、
　なんとか頑張って、そこそこ遊べる程度のソフトにしてみたいと思ってはいます。
　機能としては、
　 ・対戦は、人orPC 対 人orPC
　・石を置ける場所の事前ヒント表示
　・黒白の現在獲得石数の表示
　・勝敗の決定
　ここまでは必須として機能を実装する予定です。
　出来れば、
　 ・PCの強さ設定
　これが出来るととても良いですよね。。
　そして、最終的に、私より強いソフトになったりすれば最高ではあります。
　 ※注意事項
　マクロVBAを学ぶ上で、ごく基本事項は他のページで学習してください。
　 ExcelマクロVBA入門
　ExcelVBAとは、エクセルの操作を自動化するマクロ機能で使われているプログラミング言語です。VBAは、 「MicrosoftVisualBasicApplications」の略になります。このVBA入門シリーズでは、実務で必要とされるVBAの入門と して、基礎から業務応用までのVBA全般を基礎解説していきます。
　 Excelマクロ再入門
　VBA学習しよとして、本を読んでもWEBをみても、結局挫折してしまった方を対象に、VBA再入門と題してマクロVBAの基礎の学習を実践形式で進める連載を開始します。理屈は最低限にとどめ、とにかくマクロVBAが書けるようになることを目的とします。
　出で来る用語や意味が分からない場合は、適宜上記の該当ページを参照してください。
　少なくとも、Excelマクロ再入門は、ある程度は理解しておいてください。
　 全体の目次
　 はじめに
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながら、マクロVBAを学んで行きましょう。目的は、マクロVBAの学習であり、思考 を整理しVBAでプログラミングする学習です。従って、強いソフトを作ることが目的ではありませんので、最近流行のAIなんちゃら…なんていうのは考える つもりはありません。
　 №1．シートの用意と標準モジュールの挿入
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第1回です。まずはシートを用意しなければなりません、この シートの作り方で、その後の手間が随分と変わってきますので、しっかりと作ります。とはいえ、まずは一般的な感じで作ってみます、今後必要に応じて追加・ 変更していきます。
　 №2．ブックを開いたときの処理と初期配置
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第2回です。前回でシートの準備と標準モジュールを挿入しましたので、今回からは、マクロVBAをどんどん書き足していきます。まずは、イベントプロシージャーを作っていきます。
　 №3．自分の石を置ける場所の判定の整理
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第3回です。いよいよ自分の石を置いて、相手の石をひっくり 返す処理に進むのですが、その前に、そもそも自分の石を置ける場所はどこなのか…。クリックしたセルは、自分の石を置いて良いセルなのかの判定が必要で す。
　 №4．自分の石を置ける場所の判定の実装
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第4回です。石を置ける場所の定義を、前回は文章で書きまし た、今回は、それをもとにマクロVBAのプログラミングをしていきます。考え方は決定しているので、後はVBAに翻訳（コーディング）していくだけです。
　 №5．シート機能を拡張して今後の準備
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第5回です。前回で石を置ける場所の判定が完成しましたので、これからは、ゲームとしての機能を一つずつ追加していきます。まずは、石を置ける場所の色を変更してわかりやすくしてみます。
　 №6．黒石白石を交互に打って相手の石をひっくり返す
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第6回です。いよいよ今回は、黒石白石を交互に打てるようにします。もちろん、相手の石を挟んでいる場所は、自分の石に取り替えます。
　 №7．パス確認、終局確認、石数取得
　VBAでオセロ（リバーシ）を作っていきながらVBAを学ぶ第7回です。前回までで、黒石白石を交互に打つことができるようになりましたが、ま だまた不都合な点があります。石を打つ場所がない時に、パスが出来ないから先に進まない… 全部石が埋まっても、何も変化がない… そもそも、どっちが勝っているのかもわからない… つまり、
　 №8．石を置ける場所の表示とアニメーション
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第8回です。前回までで大分ゲームらしくなってきました。そ ろそろ、PC対戦の機能を入れたいところですが、今回は、はPC対戦の機能を入れる前に、気になる細かい部分を変更しておきます。
　 №9．PC対戦の実装
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第9回です。前回までで人が打つのであれば不自由のない機能が実装できたと思います。さて、ここからはPC対戦の機能を入れていきます。
　 №10．置く場所に重みを付けて少しだけ強く
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第10回です。前回は、PCが自動で打つ機能を実装しました。強さはともかく、とにかくPCが勝手に売ってくれるようになりました。
　 №11．相手の応手を評価してさらに強く
　VBAでオセロ（リバーシ）を作っていきながらVBAを学ぶ第11回です。前回の石を置く場所に重みを付けることで、超々初心者なら勝てるかも しれないというレベルにはなりました。ですが、ある程度オセロをやった事のある人なら、まあ負けることはないでしょう 今回は、自分の打つ場所ではなく、
　 №12．PC対PCの対戦で強さを確認
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第12回です。前回は、相手の応手を判定して、自分の置く場所を決められるようにしました。オセロソフトとしては、そこそこの強さになりました。
　 №13．パラメーターと重みを調整してさらに強く
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第12回です。前回は、ＰＣ１からＰＣ５までの5段階の状態 で、総当り対戦で強さを判定しましたが、ＰＣ５が最も強い事が確認出来ました。それでもＰＣ５では、まだまだ、ある程度オセロをやった事のある人には勝て ないレベルです。
　 №14．やはり「待った」が欲しい
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第14回です。前回で、6段階の強さのＰＣオセロが完成しま した、一番強いＰＣ６でも、まだまだそれほどの強さとは言えませんが、初心者の人なら苦戦するでしょうし、私も油断すれば負けてしまうくらいの強さには なっています。
　 №15．棋譜で対局を再現
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第15回です。棋譜が扱えるようになり、「待った」の実装も出来ました。棋譜が扱えるようになったので、今回は、対局を再現できるようにします。
　 №16．これまでを振り返りつつ全体のまとめ
　ExcelマクロVBAでオセロ（リバーシ）を作っていきながらマクロVBAを学ぶ第16回です。15回に渡って、オセロ作成をしてきました、マクロVBAコードはかなりの量になっています。今回は最終回として、これまでを振り返ってみます。

ストップウォッチ改（1/100秒）（Timer）

　ストップウォッチを作る時の、基本的なVBAコードを以前に公開しましたが、
　時々お問い合わせをいただくことがあり、それなりに重宝されているようです。
　そこで、もう少し機能強化したものを作成した次第です。
　 公開済みのストップウォッチ
　 ストップウォッチ（1/100秒）（Timer）
　ストップウォッチを作ってみましょう。機能は簡単に、・ボタンを押すと、0からスタートし時間表示が進む。・もう一度ボタンを押すとストップする。これだけです。つまり、１つのボタンで、マクロをスタートさせたり、ストップさせたりする方法の紹介になります。
　 追加する機能
　・ラップタイム（区間の時間）
　・スプリットタイム（その時点までの時間）
　これらを取得するためのボタンを追加してみました。
　 シートレイアウト
　 VBAコード
　
Option Explicit
　Private blnStop As Boolean
　Private blnStart As Boolean
　Private dblTimer As Double
　Private bLap As Double
　Private cntLap As Long
　Sub StartStop()
　　　If blnStart = True Then
　　　　　blnStop = True
　　　　　Exit Sub
　　　End If
　　　bLap = 0
　　　cntLap = 0
　　　blnStart = True
　　　blnStop = False
　　　dblTimer = Timer
　　　Do Until blnStop = True
　　　　　Cells(2, 2) = Int((Timer - dblTimer) * 100) / 100
　　　　　DoEvents
　　　Loop
　　　blnStart = False
　　　blnStop = False
　End Sub
　Sub LapSplit()
　　　cntLap = cntLap + 1
　　　Cells(cntLap + 4, 2) = cntLap
　　　Cells(cntLap + 4, 3) = Int((Timer - dblTimer) * 100) / 100 - bLap
　　　Cells(cntLap + 4, 4) = Int((Timer - dblTimer) * 100) / 100
　　　bLap = Cells(cntLap + 4, 4)
　End Sub
　Sub LapSplitClear()
　　　Range("B4").CurrentRegion.Offset(1).ClearContents
　　　bLap = 0
　　　cntLap = 0
　End Sub
　
Sub StartStop()
　これは、元々の、
　 ストップウォッチ（1/100秒）（Timer）
　ストップウォッチを作ってみましょう。機能は簡単に、・ボタンを押すと、0からスタートし時間表示が進む。・もう一度ボタンを押すとストップする。これだけです。つまり、１つのボタンで、マクロをスタートさせたり、ストップさせたりする方法の紹介になります。
　ここに掲載したVBAコードとほぼ同じです。
　 Sub LapSplit()
　ラップタイム、スプリットタイムを履歴のように記録します。
　 Sub LapSplitClear()
　ラップタイム、スプリットタイムの履歴を消去します。
　 ダウンロード
　以下でサンプルファイルをダウンロードできます。
　 エクセルのサンプルダウンロード

増殖した条件付き書式を整理統合する

　コピペによって条件付き書式は際限なく増加していきます。
　あまり増えすぎると、Excelの動作が遅くなる場合もありますし、条件や書式を変更したい時にも困ることになります。
　このような場合は、条件付き書式を消して再設定するしかなくなります、
　これを解決するVBAを考えてみました。

条件付き書式の増殖に関する、Microsoft サポート

Excel 2007 条件付き書式をコピーした場合、以前より条件付き書式が増加する
　
　こちらのページは結構有名かもしれないので、見たことのある人もいるかもしれません。
　2007で変更になった仕様によるとの言い訳は仕方ないとして、
　回避策が書かれていますが、
　 回避策
　 条件付き書式の増加により動作が遅くなった場合、 以下の手順で条件付き書式を削除後、条件付き書式を再度設定します。
　[ホーム] タブの [ルールのクリア]-[シート全体からルールをクリア] を選択します。
　同じ条件を設定するセルを適宜選択し、条件付き書式を設定します。
　これは回避策ではなく、事後処理（というか事故処理）ですよね。
　 状況
　 この動作は仕様です。
　最後は言い切りましたね。
　その潔さは認めます。
　そうです、ソフト作成において最終最後の言葉です。

増殖した条件付き書式の実例と対応


　 右のスクロールバーを見てもらえれば分かる通り、
　こうなってしまっては、手作業での修正は諦めた方が良いでしょう。
　 全て削除してから再度条件付き書式を設定するか、
　1行だけ残して（2行目を残すなら、3行目から最下行まで選択して）、ルールをクリアして、
　2行目の条件付き書式の適用範囲を変更します。
　これをVBAにするのは簡単です。
　自動記録でも十分でしょう、セル範囲くらいを変更すれば使えます。
　しかし、
　行方向・列方向に飛び飛びの範囲に設定されていたりすると、もうお手上げになります。
　ちなみに、条件付き書式が設定されているセルを全て選択するには、
　ジャンプ（Ctrl+G）→セル選択
　

簡単なVBAでの対応

全ての条件付き書式をクリアして再設定


　
Sub sample1()
　　　With Worksheets("Sheet1").Range("A1:A10")
　　　　　.FormatConditions.Delete
　　　　　.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="90%"
　　　　　.FormatConditions(1).Interior.Color = vbRed
　　　　　.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="100%"
　　　　　.FormatConditions(2).Interior.Color = vbYellow
　　　End With
　End Sub
マクロの自動記録で作成されたVBAを変更すれば簡単に作成できま。

2行目の条件付き書式だけ残しクリア後に、2行目の適用範囲を変更


　
Sub sample2()
　　　Dim ws As Worksheet
　　　Dim fObj As Object
　　　Dim i As Long
　　　Set ws = ActiveSheet
　　　ws.Range("3:1000").FormatConditions.Delete
　　　For i = ws.Rows(2).FormatConditions.Count To 1 Step -1
　　　　　Set fObj = ws.Rows(2).FormatConditions(i)
　　　　　fObj.ModifyAppliesToRange fObj.AppliesTo.Resize(999)
　　　Next
　End Sub
For Each で処理したVBAコードを試して見たところ、
　同一セル範囲に同一条件付き書式があるような特殊な場合、
　 Excelが落ちてしまう事がありました。
　このVBAコードであれば問題ないと思いますが、
　使う時には、必ずバックアップしてから実行する等の注意をしてください。
　VBAの条件付き書式の基本については、
　 マクロVBA入門：第91回.条件付き書式（FormatCondition）
　条件付き書式は、シート上で設定しておいた方が良いのですが、事前に設定しておけない場合は、VBAで条件付き書式を設定します。VBAで条件 付き書式を設定する場合は、セル（Rangeオブジェクト）のFormatConditionsコレクションにFormatConditionオブジェク トを追加することで行います。
　こちらを参考にしてください。

VBAで条件付き書式を整理統合した結果

この後に掲載してあるVBAであれば、上の画像の条件付き書式が、このように整理統合されます。
　 1行目は、歯抜けの範囲に同じ条件付き書式が設定されていたようです。
　これは、私が実際に使っているExcelですが、行挿入して書式が抜けている行があったという事です。
　ここまで統合されれば、設定漏れも分かりますし、手作業で直すも簡単です。
　こんなVBAが欲しかったという人が多くいるのではないかとの思いで作成してみました。
　私自身が、このVBAによって今後の作業がかなり楽になると思っています。

今回のVBAコードの発想について

この仕様については、私も結構悩まされてきました。
　手作業で、幾度となく条件付き書式を再設定してきました。
　頻繁に発生するシートの場合は、
　先に示したようなVBAで、
　条件付き書式を削除して再設定できるようにマクロを用意しておいたりして対処してきました。
　常々、この仕様は困ったものだとの思いと、なんとか出来ないものかとの思いは持っていました。
　最近も条件付き書式が増加しているシートがあったので、手作業で再設定していて、
　「これ、なんとか出来ないかなー、出来ないことないはずだよなー」、と思い立ち、
　いろいろ考えてみたのですが、これがかなり難しい。
　 ・何をもって、増殖してしまった条件付き書式と判定するのか
　 ・何をもって、同じ条件付き書式と判定するのか
　VBAコードのプログラミング以前に、仕様を決定出来ないのです。
　頭を整理して、良く考えてみました。
　問題は、
　数式が同じかどうか・・・

数式が同じかどうかの判定

適用先：= $A$1:$A$10
　 適用先：= $A$11:$A$20
　 この2つの条件付き書式は同じものです。
　コピペで作ったものです。
　セル範囲の条件付き書式では、多くの数式は相対参照で書かれています。
　つまり、コピーで増えた条件付き書式の数式は、コピペ先のセル参照に変更されています。
　条件付き書式が設定されているセルと、数式が参照しているセルの位置関係が同じかどうか、
　そんな判定をどのようにしたら良いのか・・・
　当初は、
　 同じセルにコピペして、その数式が同じなら同じ数式ではないか！
　このように考えてVBAを作成して公開しましたが、
　しかし、この記事をお読みになった方からより良い情報をいただきました。
　 数式をR1C1形式に変換して比較
　確かに、言われてみればその通りで、
　条件付き書式の適用範囲の先頭セルを起点としたR1C1形式で比較すれば数式の同一性が判定できます。
　そして、数式をR1C1形式に変換するには、ApplicationのConvertFormulaメソッドを使います。
　また、分断されているセル範囲を連続セル範囲へ変換する方法も、
　単純にUnionするだけだったものを力業で統合していたので改修しました。
　さらに、全VBAを見直し、プロシージャーの単位も変更しました。
　結果として、大幅に簡易なVBAになったと思います。

Application.ConvertFormulaメソッド

A1およびR1C1参照スタイルの間の数式でのセル参照を、相対参照と絶対参照の間、またはその両方に変換します。
　 Application.ConvertFormula (Formula, FromReferenceStyle, ToReferenceStyle,ToAbsolute, RelativeTo)
　
名前 必須 説明
Formula 必須 変換する数式を含む文字列を指定します。
　必ず有効な数式を指定し、数式の先頭には等号 (=) を付けてください。
FromReferenceStyle 必須 変換前の参照形式を、XlReferenceStyleの定数で指定します。
ToReferenceStyle 省略可 取得する参照スタイルを指定するXlReferenceStyleの定数です。
　この引数を省略すると参照形式は変更されず、引数FromReferenceStyleで指定された形式が使用されます。
ToAbsolute 省略可 変換された参照型を指定するXlReferenceTypeの定数です。
　この引数を省略すると、参照の種類は変更されません。
RelativeTo 省略可 1 つのセルを含むRangeオブジェクトを指定します。
　このセルは、相対参照の基点となります。

増殖した条件付き書式を整理統合するVBA


　
Option Explicit
　 '条件付き書式を格納する構造体
　Type tFormat
　　　AppliesTo As String '適用範囲
　　　Formula1 As String '数式1
　　　Formula2 As String '数式2
　　　Operator As String '演算子
　　　NumberFormat As String '表示形式
　　　FontBold As String '太字
　　　FontColor As String '文字色
　　　InteriorColor As String '塗りつぶし色
　 '追加判定したいプロパティはここに追加
　End Type
　Public Sub UnionFormatConditions(ByVal ws As Worksheet, _
　　　　　　　　　　　　　　　　　 Optional ByVal NewName As String = "")
　 '条件付き書式を格納する構造体配列
　　　Dim fAry() As tFormat
　 '条件付き書式が無い場合は終了
　　　If ws.Cells.FormatConditions.Count = 0 Then Exit Sub
　 'オプションにより元シートをコピー
　　　If NewName <> "" Then
　　　　　ws.Copy After:=ws
　　　　　Set ws = ActiveSheet
　　　　　ws.Name = NewName 'シート名のチェックは省略しています。
　　　End If
　 '条件付き書式を構造体配列へ格納
　　　Call SetFormatToType(fAry, ws)
　 '同一条件付き書式の結合：配列内でセル範囲指定文字列を結合
　　　Call JoinAppliesTo(fAry, ws)
　 '条件付き書式の統合：配列内のAppliesをFormatConditionに適用
　　　Call ModifyApplies(fAry, ws)
　End Sub
　 '条件付き書式を構造体配列へ格納
　Private Sub SetFormatToType(ByRef fAry() As tFormat, _
　　　　　　　　　　　　　　　ByVal ws As Worksheet)
　　　Dim i As Long
　　　Dim fObj As FormatCondition
　　　On Error Resume Next '.Formula2が取得できない場合の対処
　　　ReDim fAry(ws.Cells.FormatConditions.Count)
　　　For i = 1 To ws.Cells.FormatConditions.Count
　　　　　Set fObj = ws.Cells.FormatConditions(i)
　　　　　fAry(i).AppliesTo = fObj.AppliesTo.Address
　　　　　fAry(i).Formula1 = fObj.Formula1
　　　　　fAry(i).Formula2 = fObj.Formula2
　　　　　fAry(i).Operator = fObj.Operator
　　　　　fAry(i).NumberFormat = fObj.NumberFormat
　　　　　fAry(i).FontBold = fObj.Font.Bold
　　　　　fAry(i).FontColor = fObj.Font.Color
　　　　　fAry(i).InteriorColor = fObj.Interior.Color
　 '追加判定したいプロパティはここに追加
　 '数式エラーの条件付き書式は削除をする
　　　　　If isErrorFormula(fAry(i).Formula1) Or _
　　　　　　 isErrorFormula(fAry(i).Formula1) Then
　　　　　　　fAry(i).AppliesTo = ""
　　　　　End If
　　　Next
　End Sub
　 '条件付き書式の数式エラー判定
　Private Function isErrorFormula(ByVal sFormula As String) As Boolean
　　　If IsError(Evaluate(sFormula)) Then
　　　　　isErrorFormula = True
　　　Else
　　　　　isErrorFormula = False
　　　End If
　End Function
　 '同一条件付き書式の結合：配列内でセル範囲指定文字列を結合
　Private Sub JoinAppliesTo(ByRef fAry() As tFormat, _
　　　　　　　　　　　　　　 ByVal ws As Worksheet)
　　　Dim i1 As Long, i2 As Long
　　　For i1 = 1 To UBound(fAry)
　　　　　For i2 = 1 To i1 - 1
　 '計算式1,2、文字色、塗りつぶしの一致判定
　　　　　　　If isMatchFormat(fAry(i1), fAry(i2), ws) Then
　　　　　　　　　fAry(i2).AppliesTo = Union(Range(fAry(i2).AppliesTo), _
　　　　　　　　　　　　　　　　　　　　　　 Range(fAry(i1).AppliesTo)).Address
　　　　　　　　　fAry(i1).AppliesTo = ""
　　　　　　　　　Exit For
　　　　　　　End If
　　　　　Next
　　　Next
　End Sub
　 '計算式1,2、演算子、文字色、塗りつぶしの一致判定
　Private Function isMatchFormat(ByRef fAry1 As tFormat, _
　　　　　　　　　　　　　　　　 ByRef fAry2 As tFormat, _
　　　　　　　　　　　　　　　　 ByVal ws As Worksheet) As Boolean
　　　If fAry1.AppliesTo = "" Or _
　　　　 fAry2.AppliesTo = "" Then
　　　　　Exit Function
　　　End If
　　　Dim sFormula1 As String, sFormula2 As String
　　　isMatchFormat = True
　 '計算式1
　　　sFormula1 = ToR1C1(fAry1.Formula1, fAry1.AppliesTo)
　　　sFormula2 = ToR1C1(fAry2.Formula1, fAry2.AppliesTo)
　　　If sFormula1 <> sFormula2 Then isMatchFormat = False
　 '計算式2
　　　sFormula1 = ToR1C1(fAry1.Formula2, fAry1.AppliesTo)
　　　sFormula2 = ToR1C1(fAry2.Formula2, fAry2.AppliesTo)
　　　If sFormula1 <> sFormula2 Then isMatchFormat = False
　 '演算子
　　　If fAry1.Operator <> fAry2.Operator Then isMatchFormat = False
　 '表示形式
　　　If fAry1.NumberFormat <> fAry2.NumberFormat Then isMatchFormat = False
　 '太字
　　　If fAry1.FontBold <> fAry2.FontBold Then isMatchFormat = False
　 '文字色
　　　If fAry1.FontColor <> fAry2.FontColor Then isMatchFormat = False
　 '塗りつぶし
　　　If fAry1.InteriorColor <> fAry2.InteriorColor Then isMatchFormat = False
　 '追加判定したいプロパティはここに追加
　End Function
　 'A1形式をR1C1形式に変換
　Private Function ToR1C1(ByVal sFormula As String, _
　　　　　　　　　　　　　　　　ByVal sAppliesTo As String)
　　　If sFormula = "" Then Exit Function
　　　Dim rng As Range
　　　Set rng = Range(sAppliesTo)
　　　ToR1C1 = Application.ConvertFormula(sFormula, xlA1, xlR1C1, , rng.Item(1))
　End Function
　 '条件付き書式の統合：配列内のAppliesをFormatConditionに適用
　Private Sub ModifyApplies(ByRef fAry() As tFormat, _
　　　　　　　　　　　　　　ByVal ws As Worksheet)
　　　Dim i As Long
　　　Dim fObj As Object
　　　For i = ws.Cells.FormatConditions.Count To 1 Step -1
　　　　　Set fObj = ws.Cells.FormatConditions(i)
　　　　　If fAry(i).AppliesTo = "" Then
　　　　　　　fObj.Delete
　　　　　Else
　　　　　　　If fObj.AppliesTo.Address <> ws.Range(fAry(i).AppliesTo).Address Then
　　　　　　　　　fObj.ModifyAppliesToRange ws.Range(fAry(i).AppliesTo)
　　　　　　　End If
　　　　　End If
　　　Next
　End Sub
　
同じ条件付き書式かどうかの判定 は、
　 ・数式1
　・数式2
　・演算子
　・表示形式
　・太字
　・文字色
　・塗りつぶし
　以上で判定しています。
　従って、例えば、
　A1:A10は、>1という条件でFont.Size = 10
　A11:A20は、>1という条件でFont.Size = 11
　これは、同じ条件付き書式として判定し統合されてしまいます。
　実際に、このような設定を使う事がそうそうあるとは思えませんが、
　これを別の条件付き書式として判定したい場合は、
　上記VBAコードの、
　 '追加判定したいプロパティはここに追加
　これが 3箇所 ありますので、そこにプロパティを追加してください。

条件付き書式で設定できる書式

セルの書式設定のほとんどを指定できるので多くのプロパティがあります。
　VBAでこの違いを全て判定するのは、ちょっとコードを書くのが面倒です。
　特に罫線とかは、かなり多くなってしまいます。
　実際のところは、
　面倒と言うよりサンプルVBAコードとして長くなるだけで意味がないと思いました。
　しかし、そもそも、
　同じ数式、つまり同じ条件なのに書式のごく一部が違うというような設定を、多用すること自体に問題があるようにも思いますし、
　そんな使い方は、そうそうあるものではないだろうと思います。
　そして何より、あくまでサンプルVBAだという事で理解してください。
　以下は、条件付き書式で設定できるプロパティの一覧になります。
　 NumberFormatLocal
　 Font.Bold
　Font.Italic
　Font.Underline
　Font.Strikethrough
　 Font.Color
　Font.TintAndShade
　Borders(xlLeft).LineStyle
　Borders(xlLeft).TintAndShade
　Borders(xlLeft).Weight
　Borders(xlRight).LineStyle
　Borders(xlRight).TintAndShade
　Borders(xlRight).Weight
　Borders(xlTop).LineStyle
　Borders(xlTop).TintAndShade
　Borders(xlTop).Weight
　Borders(xlBottom).LineStyle
　Borders(xlBottom).TintAndShade
　Borders(xlBottom).Weight
　Interior.Pattern
　Interior.PatternThemeColor
　 Interior.Color
　Interior.TintAndShade
　Interior.PatternTintAndShade
　StopIfTrue
　つまり、すべてのプロパティの違いを判定したいのなら、
　先のVBAコードの、
　'追加判定したいプロパティはこの上に追加
　この部分に、既に入れてある、
　NumberFormatLocal
　Font.Bold
　FontColor
　InteriorColor
　これ以外を全て追加すれば良いという事です。
　ですが、正確にはこれで全てと言う訳ではありません。
　塗りつぶし効果でグラデーションを付けている場合に、
　その違いまで判定するなら、さらに多くのプロパティの判定が必要になります。
　先にも述べましたが、同じ条件でグラデーションだけを変えるなどという使い方が実際にあるとは思えませんが、
　もし使っているというのなら、基本的にシートの作成を考え直した方が良いと思います。

増殖した条件付き書式を整理統合するVBAの使い方

上記VBAコード先頭の、
　 「UnionFormatConditions」がメインのプロシージャー です。
　オプションのNewNameが設定されていれば、
　元シートをコピーしてから条件付き書式を整理統合します。
　VBAコードの詳細解説は省きますが、VBAコード内のコメントを参考に読み解いてみてください。
　以下で使い方を説明します。

アクティブシートの条件付き書式を整理統合


　
Sub sample1()
　　　Application.ScreenUpdating = False
　　　Application.Calculation = xlCalculationManual
　　　Dim ws As Worksheet
　　　Set ws = ActiveSheet
　 Call UnionFormatConditions(ws, ws.Name & "_test")
　　　Application.Calculation = xlCalculationAutomatic
　　　Application.ScreenUpdating = True
　End Sub
アクティブシートなので、念のためシートをコピーするオプションを指定しています。
　整理統合されているかの確認をしやすいので、テスト用とも言えます。

ブック全てのシートの条件付き書式を整理統合する


　
Sub sample2()
　　　Dim FileName As Variant
　　　Dim wb As Workbook
　　　Dim ws As Worksheet
　　　FileName = Application.GetOpenFilename(FileFilter:="Excelファイル, *.xls*")
　　　If FileName = False Then
　　　　　Exit Sub
　　　End If
　　　Application.ScreenUpdating = False
　　　Application.Calculation = xlCalculationManual
　　　Set wb = Workbooks.Open(FileName:=FileName, UpdateLinks:=0, ReadOnly:=True)
　　　For Each ws In wb.Worksheets
　 Call UnionFormatConditions(ws)
　　　Next
　　　Application.Calculation = xlCalculationAutomatic
　　　Application.ScreenUpdating = True
　　　FileName = Application.GetSaveAsFilename(InitialFileName:=wb.Name, _
　　　　　　　　　　　　　　　　　　　　　　　 FileFilter:="Excelファイル,*.xls*")
　　　If FileName = False Then
　　　　　Exit Sub
　　　End If
　　　wb.SaveAs FileName
　　　wb.Close SaveChanges:=True
　End Sub
ダイアログで対象のファイルを選択し、
　保存時にもダイアログでファイルを指定できるようにしています。
　全シートが変更になるので、別ブックで保存し確認できるようにしています。

増殖した条件付き書式を整理統合の最後

こうやって、VBAコードを書いてみると、
　Excelそのものも修正出来ないこともないように思われました。
　「条件付き書式の最適化」
　このようなボタンを配置して、条件付き書式を整理統合出来れば良いと思う。
　・「もとに戻す」は難しいかもしれません。
　・不具合も出るかもしれません。
　かなり勝手な言い分としては、
　実行時に注意のメッセージを出せば良いことではないかと思うのです。
　特殊な使い方をしている場合を考慮して先に進まないよりは、大多数の人の利益を優先すべきではないでしょうか。
　それこそ最後には、「それは仕様です」、と言い切ってしまえば良い話だと私は思います。
　まだ作成して自分で確認しただけのVBAなので、バグが無いとは言えません。
　といいますか、このくらいのVBAになると、バグというか想定外は存在するのが普通です。
　上記のVBAコードを使用して、Excelファイルが壊れてしまった等の苦情は受け付けませんが、
　 バグ報告は大歓迎 です。
　もしくは、
　 「もっと簡単にできるよ」、なんて情報は大大歓迎 です。

条件付き書式で変更された書式を取得する

　条件付き書式が設定されている場合、
　当然ですが見た目は、本来そのセルに設定されている書式ではなく、
　条件付き書式の条件によって設定されている書式になります。
　VBAで、この条件付き書式によって設定された書式を取得します。
　これが取得できるようになったのは、Excel2010からですので、
　このページで紹介するVBAコードはExcel2010以降でのみ有効なものです。
　 実際の画像
　 このブックでは、テーマも配色も変更しています。
　また、別シートを参照している条件付き書式も設定してあります。
　このシートをコピーして新規ブックにすると、
　 新規ブックなので、テーマや配色は標準で作成されます。
　特に目立つので、直ぐに気が付くのが色の変化です。
　変化がない部分は、基本色やその他の色（RGB指定）で設定している部分になります。
　画像ではわかりづらいですが、コジックがPゴシックにも変わってしまっています。
　右半分は、いろいろな条件付き書式を設定していますが、
　アイコンセットはアイコンなので、さすがに変化していません。
　そもそも、条件付き書式によって設定された書式を取得する必要があるのかという疑問があります。
　このようなシーンを想定してみました。
　 想定シーン
　何らかの資料（提出資料、プレゼン資料）を作ることになりました。
　資料作成の素材集めとして、作成済のExcelを30ファイル集めました。
　各ブックには、複数シートが入っているが、必要なシートはその中の1シートか2シート程度。
　資料作成に素材として何を使うかも含めて検討しているが、
　毎回、Excelブックを開いて目当てのシートを見つけていたのでは無駄が多いので、
　 必要なシートだけを集めたブックを新たに作成 することにしました。
　 想定シーンの作業での問題点と解決方法
　想定シーンの作業での問題点は、
　シートをコピペで他のブックに移したときの問題点になります。
　 問題点
　 1.シート間の数式がある場合、後でリンク切れを起こす。
　2.使用しているテーマが違う場合、色・フォントが変更されてしまう。
　3.条件付き書式で、他のシートを参照しているとリンク切れとなる。
　 解決方法
　 1.値貼り付けをすれば良いです。
　　　これだけなら手作業でも問題ありません。
　 2.配色のカラーを固定カラーに再設定
　 配色を使用したカラー設定を固定カラーに再設定
　Excel2007以降なら配色を選択して作成した場合、作成したシートを他のブックに移すと、色が変わってしまいます、そこで、配色ではな く、RGB値で色を再設定することで、元々の色をそのままにして、他のブックに移すことが出来ます。以下は、この目的で色を再設定するマクロVBAになり ます。
　　　ここでは、グラフの色も変更しています。
　 3.今までこれが解決できませんでした。
　　　Excel2010で、条件付き書式によって設定された書式を取得することができるようになっています。
　 今回のメインテーマ となります。
　 条件付き書式によって設定された書式の取得方法
　Rangeオブジェクトのプロパティに、Excel2010で追加された、
　 DisplayFormatプロパティ
　これを使う事で、条件付き書式で表示された書式を取得できるようになっています。
　DisplayFormatプロパティは、 DisplayFormatオブジェクト を取得します。
　DisplayFormatオブジェクトの各種プロパティを参照することで、
　表示されている書式を取得することが出来ます。
　 DisplayFormatオブジェクトのプロパティ
　
名前 説明
AddIndent 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトについて、セル内の文字列の配置で縦または横位置を均等に割り付けるときに、文字列を自動的にインデントするかどうかを示す値を返します。値の取得のみ可能です。
Application オブジェクト修飾子を指定せずに使用した場合、Microsoft Excel アプリケーションを表す Application オブジェクトを返します。オブジェクト修飾子を指定した場合、指定したオブジェクトを作成した Application オブジェクトを返します。値の取得のみ可能です。
Borders 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトの境界線を表す Borders オブジェクトを返します。値の取得のみ可能です。
Characters 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトのテキスト内の文字範囲を表す Characters オブジェクトを返します。値の取得のみ可能です。
Creator 現在のオブジェクトが作成されたアプリケーションを示す 32 ビットの整数を取得します。値の取得のみ可能です。長整数型 (Long) の値を使用します。
Font 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトのフォントを表す Font オブジェクトを返します。値の取得のみ可能です。
FormulaHidden 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトについて、ワークシートが保護されているときに数式を非表示にするかどうかを示す値を返します。値の取得のみ可能です。
HorizontalAlignment 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトの水平方向の配置を表す値を返します。値の取得のみ可能です。
IndentLevel 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトのインデント レベルを表す値を返します。値の取得のみ可能です。
Interior 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトの内部を表す Interior オブジェクトを返します。値の取得のみ可能です。
Locked 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトがロックされているかどうかを示す値を返します。値の取得のみ可能です。
MergeCells 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトに、結合されたセルが含まれているかどうかを示す値を返します。値の取得のみ可能です。
NumberFormat 現在のユーザー インターフェイスに表示されるている、関連付けられた Range オブジェクトの表示形式を表す値を返します。値の取得のみ可能です。
　 これが正しく取得できませんでした。
NumberFormatLocal 現在のユーザー インターフェイスに表示されるている、関連付けられた Range オブジェクトの表示形式を、ユーザーの言語の文字列で表す値を返します。値の取得のみ可能です。
Orientation 現在のユーザー インターフェイスに表示されるている、関連付けられた Range オブジェクトの文字列の向きを表す値を返します。値の取得のみ可能です。
Parent 指定されたオブジェクトの親オブジェクトを取得します。値の取得のみ可能です。
ReadingOrder 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトの読み取り順序を返します。値の取得のみ可能です。
ShrinkToFit 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトについて、使用可能な列幅に収まるように自動的に文字列を縮小するかどうかを示す値を返します。値の取得のみ可能です。
Style 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトのスタイルを表す、Style オブジェクトを含む値を返します。
VerticalAlignment 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトの垂直方向の配置を表す値を返します。値の取得のみ可能です。
WrapText 現在のユーザー インターフェイスに表示されている、関連付けられた Range オブジェクトについて、文字列を折り返すかどうかを示す値を返します。値の取得のみ可能です。
以下で、シートコピーの問題点を解決するためのVBAコードを掲載します。
　まずは、実装する機能と実装しない機能について
　 実装する機能と実装しない機能
　 実装する機能
　 ・指定シートをコピーし新規シートを作成
　・シート全体を値貼り付け
　・条件付き書式で表示されている書式を通常書式として設定
　・条件付き書式を削除
　・フォント、塗りつぶし、罫線の色を固定色に変更
　・新規作成シートを新規ブックへ移動
　 実装しない機能
　 ・グラフおよび図形の色については対応していません
　 配色を使用したカラー設定を固定カラーに再設定
　Excel2007以降なら配色を選択して作成した場合、作成したシートを他のブックに移すと、色が変わってしまいます、そこで、配色ではな く、RGB値で色を再設定することで、元々の色をそのままにして、他のブックに移すことが出来ます。以下は、この目的で色を再設定するマクロVBAになり ます。
　　こちらを見ていただければ理解していただけると思いますが、
　　VBAコードが非常に長くなりますし、全てのグラフに対応するのはとても大変です。
　　必要な場合は、上のページを参考にして、下のサンプルに組み込んでみて下さい。
　 ・塗りつぶしの効果とパターンは対応しない
　　通常書式、条件付き書式ともに対応しません。
　　VBAが面倒な割に、実際に使っている人は少ないと思うので。
　 ・条件付き書式の表示形式は取得できない
　　これはExcelのバグなのか、単なる実装漏れなのか・・・
　　でも、下のサンプルでは、別の方法で無理矢理対応しています。
　 シートコピーの問題点を解決して、新規ブックのシートに切り離すVBA
　
Option Explicit
　Public Function CopySheet(ByVal ws As Worksheet) As Workbook
　　　Dim wsNew As Worksheet
　　　Dim wsW As Worksheet
　　　Dim myRange As Range
　　　Dim fObj As Object
　　　Dim fRange As Range
　　　Dim aryDiagona As Variant
　　　Dim sFormat As String
　　　Dim i As Long
　 '事前設定
　　　aryDiagona = Array(xlDiagonalDown, xlDiagonalUp, xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlInsideHorizontal, xlInsideVertical)
　 '指定シートをコピーし新規シートを作成
　　　ws.Copy After:=ws
　　　Set wsNew = ActiveSheet
　　　Set wsW = Worksheets.Add '表示形式の確認で使うワークシート
　 'シート全体を値貼り付け
　 'Valueの代入ではエラーになる場合があるので普通に貼り付け
　　　wsNew.Cells.Copy
　　　wsNew.Cells.PasteSpecial Paste:=xlPasteValues
　 '条件付き書式で表示されている書式を通常書式として設定
　 '条件付き書式を使っていない場合はエラーとなる
　　　On Error Resume Next
　　　Set fRange = wsNew.Cells.SpecialCells(xlCellTypeAllFormatConditions)
　　　If Err Then
　　　　　Err.Clear
　　　Else
　　　　　On Error GoTo 0
　　　　　For Each myRange In fRange
　　　　　　　With myRange.DisplayFormat
　 'フォント
　　　　　　　　　myRange.Font.Color = .Font.Color
　　　　　　　　　myRange.Font.Bold = .Font.Bold
　　　　　　　　　myRange.Font.Italic = .Font.Italic
　　　　　　　　　myRange.Font.Strikethrough = .Font.Strikethrough
　 '塗りつぶし
　　　　　　　　　myRange.Interior.Color = .Interior.Color
　 '罫線
　　　　　　　　　For i = LBound(aryDiagona) To UBound(aryDiagona)
　　　　　　　　　　　If .Borders(aryDiagona(i)).LineStyle <> XlLineStyle.xlLineStyleNone Then
　　　　　　　　　　　　　myRange.Borders(aryDiagona(i)).LineStyle = .Borders(aryDiagona(i)).LineStyle
　　　　　　　　　　　　　myRange.Borders(aryDiagona(i)).Weight = .Borders(aryDiagona(i)).Weight
　　　　　　　　　　　　　myRange.Borders(aryDiagona(i)).Color = .Borders(aryDiagona(i)).Color
　　　　　　　　　　　End If
　　　　　　　　　Next
　 '表示形式、これは取得できないようです
　　　　　　　　　myRange.NumberFormatLocal = .NumberFormatLocal
　 'そこで条件付き書式を順に確認
　　　　　　　　　wsW.Range("A1") = myRange
　　　　　　　　　wsW.Range("A1").NumberFormatLocal = myRange.NumberFormatLocal
　　　　　　　　　If myRange.Text <> wsW.Range("A1").Text Then
　　　　　　　　　　　For i = myRange.FormatConditions.Count To 1 Step -1
　　　　　　　　　　　　　Set fObj = myRange.FormatConditions(i)
　　　　　　　　　　　　　If TypeName(fObj) = "FormatCondition" And _
　　　　　　　　　　　　　　　Not IsEmpty(fObj.NumberFormat) Then
　　　　　　　　　　　　　　　wsW.Range("A1").NumberFormatLocal = CStr(fObj.NumberFormat)
　　　　　　　　　　　　　　　If myRange.Text = wsW.Range("A1").Text Then
　　　　　　　　　　　　　　　　　myRange.NumberFormatLocal = fObj.NumberFormat
　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　End If
　　　　　　　　　　　Next
　　　　　　　　　End If
　　　　　　　End With
　　　　　Next
　　　End If
　　　On Error GoTo 0
　 '条件付き書式を削除
　　　For i = wsNew.Cells.FormatConditions.Count To 1 Step -1
　　　　　Set fObj = wsNew.Cells.FormatConditions(i)
　　　　　Select Case fObj.Type
　　　　　　　Case xlIconSets 'アイコンセット
　　　　　　　Case xlDatabar 'データバーは条件付き書式を変更
　　　　　　　　　Stop
　　　　　　　　　fObj.BarBorder.Color.Color = fObj.BarBorder.Color.Color
　　　　　　　　　fObj.BarColor.Color = fObj.BarColor.Color
　　　　　　　Case Else
　　　　　　　　　wsNew.Cells.FormatConditions(i).Delete
　　　　　End Select
　　　Next
　 'フォント、塗りつぶし、罫線の色を固定色に変更
　　　For Each myRange In wsNew.UsedRange
　 'フォント
　　　　　myRange.Font.ThemeFont = xlThemeFontNone
　　　　　myRange.Font.Name = myRange.Font.Name
　　　　　If myRange.Font.ColorIndex <> xlColorIndexNone Then
　　　　　　　myRange.Font.Color = myRange.Font.Color
　　　　　End If
　 '塗りつぶし
　　　　　If myRange.Interior.ColorIndex <> xlColorIndexNone Then
　　　　　　　myRange.Interior.Color = myRange.Interior.Color
　　　　　End If
　 '罫線
　　　　　For i = LBound(aryDiagona) To UBound(aryDiagona)
　　　　　　　If myRange.Borders(aryDiagona(i)).ColorIndex <> xlColorIndexNone Then
　　　　　　　　　myRange.Borders(aryDiagona(i)).Color = myRange.Borders(aryDiagona(i)).Color
　　　　　　　End If
　　　　　Next
　　　Next
　 '元のシートを選択
　　　ws.Select
　 '新規作成シートを新規ブックへ移動
　　　wsNew.Move
　　　Set CopySheet = ActiveWorkbook
　 '表示形式の確認で使ったワークシートの削除
　　　Application.DisplayAlerts = False
　　　wsW.Delete
　　　Application.DisplayAlerts = True
　End Function
　
Functionプロシージャーになります。
　Function CopySheet
　 戻り値は、、コピーで作った新規ブックです。
　詳しく解説出来ませんので、
　VBA内のコメントを参考にしてVBAを読んでください。
　 注意点
　実装しない機能として、
　「条件付き書式の表示形式は取得できない」、と書きましたが。
　何度か確認しましたが、
　DisplayFormatの表示形式のプロパティ
　.NumberFormat
　.NumberFormatLocal
　どちらも正しく取得できないようです。
　そこで、上のVBAサンプルでは、
　実際に表示されているTextを、
　条件付き書式で設定している表示形式に照らして、一致していればその表示形式を設定するようにしています。
　この部分は、結構きわどい処理となっていますので、書式によっては有効とならない場合もあるかもしれません。
　 使い方
　アクティブシートを新規ブックにコピーします。
　
Sub sample()
　　　Dim wb As Workbook
　　　Set wb = CopySheet (ActiveSheet)
　End Sub
CopySheetの戻り値は、コピーで作った新規ブックになります。
　新規ブックは、シートをMoveして作成しているので、シート数は1つです。
　複数シートの処理や複数ブックの処理が必要な場合は、
　Callする側で制御すれば、割と簡単に実装できるはずです。
　書式のパターンは非常にたくさんあるので、全てをテストはしていません。
　バグや考慮漏れの指摘があれば随時修正します。
　こういう処理のVBAを書いていると良く分かることがあります。
　それは、
　Excelに機能があるからと言って、何でも使うのはどうかという事です。
　出来る限り、
　基本的な機能・誰でも知っている機能だけを使ってブック・シートを作ったほうが良いという事です。
　そうすることで、
　メンテナンス性も良くなるし、ファイルを誰かに引き継いだ時にも苦労しなくて済むという事です。

順列の全組み合わせ作成と応用方法

　配列の要素の順番を入れ替えて、順列を作成しします、
　ここでは、順列作成のアルゴリズムの解説より、それを使う方法についてのサンプルが主体となります。
　順列は、出現順序の違いが問題となる場合に必要となります。
　 順列とは
　 1,2,3 の場合であれば、以下の 6通り になります。
　1,2,3
　1,3,2
　2,1,3
　2,3,1
　3,1,2
　3,2,1
　作成される順列の数は、要素数の階乗となります。
　 3! = 3*2*1 = 6
　タイトルおよび以下でも、「全組み合わせ」と書いていますが、
　順列全てということであり、数学の「組み合わせ」と言う意味ではありません。
　数学の「組み合わせ」とは、順番違いは1通りとして扱うものです。
　 順列の全組み合わせを作成するFunction
　配列を与えると、 再帰処理で順列の全組み合わせを作成 します。
　結果は、 2次元配列で返します。
　
Public Sub permutation(ByRef aryIn, ByRef aryOut, Optional ByVal i As Long = 0)
　　　Dim j As Long
　　　Dim ix As Long
　　　Dim sTemp
　　　Dim ary
　　　If i < UBound(aryIn) Then
　　　　　For j = i To UBound(aryIn)
　 '配列を入れ替える
　　　　　　　ary = aryIn
　　　　　　　sTemp = aryIn(i)
　　　　　　　aryIn(i) = aryIn(j)
　　　　　　　aryIn(j) = sTemp
　 '再帰処理、開始位置を+1
　　　　　　　Call permutation(aryIn, aryOut, i + 1)
　　　　　　　aryIn = ary '配列を元に戻す
　　　　　Next
　　　Else
　 '配列の最後まで行ったので出力
　　　　　If IsEmpty(aryOut) Or Not IsArray(aryOut) Then
　　　　　　　ix = 0
　　　　　　　ReDim aryOut(UBound(aryIn), ix)
　　　　　Else
　　　　　　　ix = UBound(aryOut, 2) + 1
　　　　　　　ReDim Preserve aryOut(UBound(aryIn), ix)
　　　　　End If
　　　　　For j = LBound(aryIn) To UBound(aryIn)
　　　　　　　aryOut(j, ix) = aryIn(j)
　　　　　Next j
　　　End If
　End Sub
このアルゴリズム自体は、どこにでもあるものです。
　上記のコードは、使い回しやすいように、
　パブリック変数を使わずに、また、できるだけ引数を減らして書いたものです。
　戻り値は、2次元となっています。
　1次元が要素数、2次元が順列数となっています。
　動的配列の要素数を変えられるのは、一番下の次元に限定されているため、
　作成する順列は、2次元で増やしていくために、このようにしています。
　順列の全組み合わせを作成する方法としては、
　配列内で順序を入れ替えつつ順に取り出すか、
　配列から取り出してはそれを削除していくかのどちらかになるでしょう。
　上のコードでは、配列内で順序を入れ替えつつ作成しています。
　 使用例1 ・・・ 配列の順列を作成しシートへ出力
　配列を与えて、戻ってきた2次元配列をシートに出力しています。
　
Sub sample1()
　　　Dim aryIn
　　　Dim aryOut
　 '入力配列
　　　aryIn = Array(1, 2, 3, 4, 5)
　 '順列作成
　　　Call permutation(aryIn, aryOut)
　 'シートへ出力
　　　Cells.ClearContents
　　　Range("A1").Resize(UBound(aryOut, 2) + 1, UBound(aryOut, 1) + 1) = _
　 WorksheetFunction.Transpose (aryOut)
　End Sub
返ってくる2次元配列は、縦横がシート出力時のイメージと違います。
　シートに出力する時には、
　見やすいように、2次元を入れ替え順列数を縦に出力しています。
　2次元を入れ替える方法としては、 Transpose関数 を使うと非常に簡便にできてしまいます。
　 動的2次元配列の次元を入れ替えてシートへ出力（Transpose）
　動的配列を使い様々な処理をした後にシートへ出力しようとしたとき、縦横が違っている為そのまま出力できません、そもそも、動的配列の要素数を Redimで変更できるのは、最下位の次元のみになります。2次元配列の場合、ReDimmyArray(2,10) ReDimmyArray(2,11) これはOKですが、
　 使用例2 ・・・ 区切り文字で区切られた文字列の順列を作成
　サーチエンジンでの検索文字のように、半角スペースで区切られた複数の単語が並んでいる場合です。
　この単語の順列を作成し、元のように半角スペースで区切った文字列を作成します。
　区切り文字をワイルドカードの"*"にすれば、
　Like演算子での部分一致判定としても利用することでが出来ます。
　結果として、全ての順序での出現チェックをすることが出来るようになります。
　（この処理だけであれば、順列以外での方法がいくらでもありますが）
　
Sub sample2()
　　　Dim aryIn
　　　Dim aryOut
　　　Dim sryRtn
　　　Dim i As Long
　　　Dim i1 As Long
　　　Dim i2 As Long
　　　Dim sString As String
　　　Dim sDelimiter As String
　 '入力配列
　　　sString = "A B C D E"
　　　sDelimiter = " " '区切り文字
　　　aryIn = Split(sString, sDelimiter)
　 '順列作成
　　　Call permutation(aryIn, aryOut)
　 'シートへ出力
　　　ReDim aryRtn(UBound(aryOut, 2))
　　　For i2 = LBound(aryOut, 2) To UBound(aryOut, 2)
　　　　　For i1 = LBound(aryOut, 1) To UBound(aryOut, 1)
　　　　　　　If i1 = LBound(aryOut, 1) Then
　　　　　　　　　aryRtn(i2) = aryOut(i1, i2)
　　　　　　　Else
　　　　　　　　　aryRtn(i2) = aryRtn(i2) & sDelimiter & aryOut(i1, i2)
　　　　　　　End If
　　　　　Next
　　　Next
　　　Cells.ClearContents
　　　For i = LBound(aryRtn) To UBound(aryRtn)
　　　　　Cells(i + 1, 1) = aryRtn(i)
　　　Next
　End Sub
・区切り文字で区切って配列を作成
　・順列作成
　・返ってきた2次元配列から、区切り文字を入れた文字列作成
　・シートに出力
　このような流れになっています。
　 使用例3 ・・・
　配列から、任意の数の要素を取り出し、その順列を作成します。
　
Sub sample3()
　　　Dim aryIn
　　　Dim aryOut
　　　Dim aryNum1
　　　Dim aryNum2
　　　Dim aryTemp
　　　Dim pCnt As Integer
　　　Dim i1 As Long
　　　Dim i2 As Long
　　　Dim ix As Long
　　　Dim sTemp1 As String
　　　Dim sTemp2 As String
　　　Dim flg As Boolean
　 '入力配列
　　　aryIn = Array("A", "B", "C", "D", "E")
　　　pCnt = 3 '取り出す数
　 '入力配列から指定数を取り出す
　 'まずは、1,2,3,4,5を作成
　　　ReDim aryTemp(UBound(aryIn))
　　　For i1 = 0 To UBound(aryIn)
　　　　　aryTemp(i1) = i1
　　　Next
　 '1,2,3,4,5の順列作成
　　　Call permutation(aryTemp, aryNum1)
　 '1,2,3,4,5の順列から先頭の指定数を取り出す
　 'ここは組み合わせを作りたいので順序違いも省く
　　　ix = 0
　　　ReDim aryNum2(pCnt - 1, ix)
　　　For i2 = 0 To UBound(aryNum1, 2)
　　　　　sTemp1 = ""
　　　　　sTemp2 = ""
　　　　　flg = True
　　　　　If i2 = 0 Then
　　　　　　　sTemp1 = "1"
　　　　　　　sTemp2 = "2"
　　　　　Else
　　　　　　　For i1 = 0 To pCnt - 1
　　　　　　　　　sTemp1 = sTemp1 & "_" & aryNum1(i1, i2 - 1)
　　　　　　　　　sTemp2 = sTemp2 & "_" & aryNum1(i1, i2)
　　　　　　　　　If i1 > 0 Then
　　　　　　　　　　　If aryNum1(i1 - 1, i2) > aryNum1(i1, i2) Then
　　　　　　　　　　　　　flg = False
　　　　　　　　　　　End If
　　　　　　　　　End If
　　　　　　　Next
　　　　　End If
　　　　　If sTemp1 <> sTemp2 And flg = True Then
　　　　　　　ReDim Preserve aryNum2(pCnt - 1, ix)
　　　　　　　For i1 = 0 To pCnt - 1
　　　　　　　　　aryNum2(i1, ix) = aryNum1(i1, i2)
　　　　　　　Next
　　　　　　　ix = ix + 1
　　　　　End If
　　　Next
　 '順列作成しつつシートへ出力
　　　Cells.ClearContents
　　　ix = 1
　 '組み合わせ数の繰り返し
　　　For i2 = 0 To UBound(aryNum2, 2)
　 '入力配列から指定数の組み合わせの配列作成
　　　　　aryOut = ""
　　　　　ReDim aryTemp(pCnt - 1)
　　　　　For i1 = 0 To pCnt - 1
　　　　　　　aryTemp(i1) = aryIn(aryNum2(i1, i2))
　　　　　Next
　 '順列作成
　　　　　Call permutation(aryTemp, aryOut)
　 'シートへ出力
　　　　　Cells(ix, 1).Resize(UBound(aryOut, 2) + 1, UBound(aryOut, 1) + 1) = _
　　　　　　　WorksheetFunction.Transpose(aryOut)
　　　　　ix = ix + UBound(aryOut, 2) + 1
　　　Next
　End Sub
A,B,C,D,E
　この中から、
　A,B,C → 順列作成
　A,B,D → 順列作成
　・・・
　B,C,D → 順列作成
　・・・
　C,D,E → 順列作成
　このように3つを取り出してその順列を作成します。
　ここでの3つの取り出しは、数学でいう「組み合わせ」であり、順序違いは1つとして数えます。
　5個から3個取り出す組み合わせ数は、
　 5! / (3! * (5-3)! = 10
　この組み合わせ作成は、もちろん組み合わせ用のアルゴリズム作成もあるでしょう。
　しかし、ここではあえて順列作成の結果を応用しています。
　この10通りの組み合わせについて、
　それぞれ順列を作成し、順次シートに出力しています。
　最終的な全順列の数は、
　 5! / (3-2)! = 60
　 実務での使用場面があるかどうか、若干疑問はありますが、
　必要になった時に、いつでも使えるように用意しておくという意味もあります。

他ブックへのリンクエラーを探し解除

　 リンクエラーが見つけられない ・・・
　「リンクの編集」で、「リンクの解除」を選択しても リンクが削除できない ・・・
　こんな経験をした人は多いのではないでしょうか。
　エクセルをいろいろと操作していると、意図せずに参照先が別ブックになってしまい、
　かつ、その参照先のブックが無くなってしまっている・・・
　こんな場合に、リンクエラーとなります。
　通常は、「リンクの編集」→「リンクの解除」で消せるのですが、
　この操作で消せないリンクエラーがたまに存在します。
　もちろん大前提として、
　 外部（他ブック）リンクはなるべく使用しないほうが良い ということだけ言っておきます。
　※この場合のリンクにはハイパーリンクは含まれません。
　Excelファイルを開いたときに、以下のダイアログメッセージがでて、
　 「更新する」を選択すると、
　 このようなダイアログメッセージが出るときがあります。
　ここで、「リンクの」編集を選択するか、
　「続行」を選択して開いた後に、リボンの「データ」→「リンクの編集」を選択すると、
　 「状態」が「エラー:・・・」となっているものが、リンク先のファイルが存在しないエラーとなります。
　「状態」が「OK」のものは、リンク先のファイルが存在しているものになります。
　エラーとなっているリンクを選択して、「リンクの解除」で通常は消せるのですが、
　時おりこの操作で消せないエラーが存在します。
　どういう場合に、「リンクの解除」で消せなくなるのか・・・
　どのようにリンクエラーを探したら良いか・・・
　かいつまんで解説します。
　 「リンクの解除」で消せるもの、消せないもの
　・ 「リンクの解除」で消せるもの
　 数式、ボタン等の登録マクロ
　・ 「リンクの解除」で消せないもの
　 名前定義、条件付き書式、入力規則
　名前定義は、定義だけなら他に影響するものではなく名前定義を使った数式が外部リンクとして認識されます。
　条件付き書式や入力規則は、そもそも通常操作では他ブックを参照できない仕様になっています。
　これらは、 シートを別ブックや新規ブックに移動したりすることで発生 するものになります。
　概ねこのような感じではありますが、絶対とは言えないものです。
　大体こんな感じだという程度にとらえておいてください。
　つまり、リンクエラーが解消できない場合は、
　「条件付き書式」「入力規則」このどちらかにリンクエラーが残っている場合になるでしょう。
　 外部（他ブック）リンクの探し方
　・ 数式
　「検索」で、
　検索する文字列：[
　検索場所：ブック
　検索対象：数式
　このように指定して、「全てを検索」
　 表示された、一覧の数式を見れば外部参照であることがわかります。
　つまり他ブックを参照している場合は、"[ブックのパス\ブック名]"このようになっているので、
　Excelとして特別な記号[を探せばよいということです。
　検索文字として、".xls"でも大抵の場合は良いのですが、
　リンク切れを起こした時の状況によっては、
　"[Book1]"のように拡張子がない場合も存在します。
　これは、保存前のブックを参照している状態で、そのブックが無くななってしまったような場合に発生します。
　・ 名前定義
　名前の管理を開いてください。
　「数式」→「名前の管理」（Ctrl+F3）
　 「名前の管理」のダイアログが表示され、名前の定義の一覧が表示されます。
　 参照範囲を見れば、外部参照が確認できます。
　ここで、選択して「削除」で消すことができます。
　この削除が失敗することは滅多にありません。
　・ ボタン等の登録マクロ、条件付き書式、入力規則
　これらを簡単に探す方法がありません。
　外部参照しているかを一旦おいとけば、
　「ジャンプ」（Ctrl+G）
　 「セル選択」
　 ここで、
　「オブジェクト」「条件付き書式」「データの入力規則」
　それぞれを選択して、「OK」をすれば、
　オブジェクトまたは当該セルが選択されます。
　これで、場所はわかります。
　しかし、具体的に外部リンクなのかどうかは内容を一つずつ確認しなければなりません。
　そして、これはシート毎に行う必要があります。
　つまり、
　シート数が多く、それぞれのシートに多くの設定がある場合には、
　ほとんど探しようがないという状態になってしまいます。
　このように外部（他ブック）リンクを探すには、かなりの手間がかかります。
　外部リンクを探せるマクロVBAがあればとても便利です。
　しかしWEBを探してみましたが、すっきりと探してくれるマクロVBAは見つけられませんでした。
　そこで、自分でも必要で使いたいということで、マクロを作成したのでここに公開します。
　公開にあたって、かなり機能を盛り込みました。
　自分で使うだけなら、UIや使い勝手はどうでも良いのですが、
　公開するのであれば、せっかくなのでもっともらしいアプリっぽくしてみました。
　マクロVBAもかなり大きくなってしまったので、VBAコードは次ページに掲載しています。
　VBAの詳しい解説は省略していますが、
　意図的に、細かいテクニックをいろいろなパターンで使っていますので、
　VBA内のコメントを頼りにコードを読み解いていくのは、VBAの良い勉強になると思います。
　 他ブックへのリンクエラーを探し解除するマクロ
　一旦掲載後に変更しています。
　変更前後を掲載していますので、プロシージャー分割等の参考にしてください。
　 機能概要
　「検索開始」ボタン
　・指定ブックの外部（他のブック）リンクを全て取得して一覧表示します。
　　リンク切れかどうかにかかわらず、全ての外部（他のブック）リンクを出力します。
　・リンク判定として、リンク切れの場合は「×」、数式が複雑で判定困難な場合は「△」を出力します。
　・削除すべきリンクについては、削除欄に「する」を出力。
　「削除」ボタン
　削除欄「する」のリンクを削除します。
　「表示最大件数」について
　外部（他のブック）リンクは、正常かエラーかにかかわらずセル毎に全て一覧に出力します。
　行全体、列全体に対して（条件付き書式や入力規則が）リンク設定されている場合は膨大な数となってしまいます。
　連続セルが同一設定の場合はセル範囲で出力するようにしていますが、
　1行おきに交互に違う設定がしてある場合等、
　セル範囲でまとめて表現できない場合に出力行数が膨大になってしまう場合があります。
　そのような場合の対応として、「表示最大件数」を超えた時点で処理を終了しています。
　また、リンクされている件数が多いと多大な処理時間がかかってしまうので、
　最初は少ない数字にして確認したほうが良いでしょう。
　 シート構成
　シートは、「リンクエラー検索」の一つだけです。
　 全体の流れ
　「検索開始」ボタン
　検索対象は、
　 数式
　名前定義
　条件付き書式
　入力規則
　ボタン等の登録マクロ
　これら以外にも存在する可能性はありそうですが、特殊なものになるでしょう。
　全てに対応する必要もないとは思いますが、
　今後、対応したほうが良いようなものが出てきたら本ページおよびマクロに追加していきます。
　↓
　検索対象のブックを選択
　このマクロブック以外が開かれているかどうかで動作が分かれます。
　・他のブックが何も開かれていない場合
　ファイルを開くダイアログ（VBA標準のダイアログ）が表示されます。
　検索対象のブックを指定してください。
　・他のブックが開かれている場合
　ブックの選択（ユーザーフォーム）が表示されます。
　 既に開かれているブックが検索対象なら、ここで選択し「OK」
　開かれていないブックを検索するなら、
　「Browse」でファイルを開くダイアログが開かれますのでそこで選択してください。
　↓
　結果が5行目以降に表示されます。
　・D列「リンク判定」は、リンク先のファイルの存在判定結果です。
　　×：リンク先ファイルなし
　　△:リンク数式が複雑なため判定保留
　　　→関数がネストされている場合、
　　　　ファイル名を全て正しく抽出するのが困難であり、
　　　　ユーザーが自身で判定したほうが良いだろうということです。
　・E列「削除」は、「削除」ボタンで削除するかどうかを指定しますが、
　　検索時には、削除推奨のリンクに対して「する」を設定しています。
　↓
　検索完了メッセージが表示されます。
　メッセージ内容は、
　処理時間：処理にかかった時間
　確認したセル数：チェックしたセルおよびオブシェクト数の総数
　外部リンク数：見つかった外部（他ブック）リンク数
　エラーリンク数：リンク先のファイルが存在しない数
　保留リンク数：リンク数式が複雑なため判定保留した数
　確認したら「OK」
　↓
　表示された一覧を確認し、E列の「する」を適切に指定してください。
　↓
　「削除」ボタンでE列「する」が削除されます。
　この「削除」はマクロ動作なので元に戻すことができません。
　万一間違った削除をしてしまったときは、
　対象ブックは「保存しない」で閉じることで対応してください。
　※件数が少ないときは、
　　今後の事を踏まえると手動で削除したほうが良いでしょう。
　　手動で削除することで、その操作がしっかりと頭に残りますので。
　 他ブックへのリンクエラーを探し解除するマクロ
　一旦掲載後に変更しています。
　変更前後を掲載していますので、プロシージャー分割等の参考にしてください。

Excelシートの複雑な計算式を解析するVBA

　セルに入力されている数式が折り返されていて複数行（ときに3行以上）になっている場合、
　数式バーで見ていたのでは、どんな数式なのかがさっぱりわからなくなります。
　このような複雑な数式を分解し、分かり易く表示するVBAを作成しました。
　最初に言っておきますが、
　そもそも、そのような複雑な数式は作らないほうが良いというのが基本です。
　作業セル（計算セル）を使い、順序立ててわかるようにしておくべきものです。
　複雑な数式は一見すごいように見えてしまいますが、
　追加々で組み立てていくと割と簡単に複雑な数式が出来上がってしまいます。
　このような方法で作成されるので、
　数式全体に無駄が多く条件が整理されていないなど最適化されていない数式である場合が多々あります。
　とはいえ、
　既に作成済み（誰が作ったかはこの際抜きにして）の数式であれば、
　変更が必要になった時など、いずれその数式を解析しなければならない時がきます。
　今回のVBAは、そんな時の手助けツールとして作成したものです。
　今回のVBAを作ろうとしたとき、最初はどうしてよいか戸惑いました。
　やたら複雑なことを考えては、VBAでは厳しいかなと諦めてしまったり。
　・・・そして、よくよく落ち着いて考えたら・・・
　人が（私が）複雑な数式を読むときの手順をその順番通りにやれば良いのだと気づき、
　今回のVBA完成に至っています。
　解析の中核としては、一番外側の関数の引数を分解しているだけです。
　これは人が（私が）複雑な数式を読むときの基本手順です。
　そして、これを繰り返して最小単位の関数にまで掘り下げています。
　つまり今回のVBAは、これをそのままVBAにしたということです。
　=IF(COUNTIF(範囲,検索条件)=1,A1,VLOOKUP(検索値,範囲,列番号,検索方法))
　このような数式の場合、まず最初にIF関数の引数に分解します。
　論理式：COUNTIF(範囲,検索条件)=1
　真の場合：A1
　真の場合：VLOOKUP(検索値,範囲,列番号,検索方法
　そして次に、引数の数式を確認し、これが複雑なら同じことを繰り返します。
　私はこれを数式バーを見ながら、必要に応じて数式内で改行(Alt+Enter)したりしながら解読します。
　より複雑で長い数式であれば、
　メモ帳に数式を貼り付けて、適宜改行したり、字下げしながら解読していきます。
　複雑な数式の解析としては、実務的にはこれで十分なはずです。
　結果のシートへの表示方法は好みもありますので、
　自由にカスタマイズして使ってもらえれば良いと思います。

複雑な計算式を解析するVBAの概要

シート構成
　シートは以下の2つです。
　数式解析 ・・・ シート名はVBAでは使っていないので何でも構いません。
　関数構文 ・・・ VBA内のモジュールレベル定数で名称を指定しています。
　 数式解析
　処理メインのシートになります。
　 B1:K1はセル結合します。
　数式が折り返されて、数式全体がみえるようにする目的があります。
　1行目の行高さは、VBA内で自動調整しています。
　B1の番地は、VBA内のモジュールレベル定数で指定していますので変更可能です。
　このB1セルに数式を文字列として貼り付け解析します。
　（先頭の=はあってもなくても良い）
　「消去」：2行目以下の解析結果部分を消去します。
　「全解析」：数式を全て最小単位の関数になるまで解析します。
　B1セルをダブルクリック：一番外側の数式だけを分解します。
　 2行目や4行目の数式（のある行）をダブルクリックすることで、
　その数式を分解し、当該行の下に行挿入して引数を出力します。
　順次これを繰り返すことで、数式内の必要な部分を解析していけます。
　A列はネストの深さレベルを表す数字になります。
　 関数構文
　数式を分解したときに、関数の引数名の表示に使います。
　 A列に関数名、B列以降に引数名を入れておきます。
　ここに設定した引数名が、解析結果の時に表示されます。
　未登録の関数は、1行目の名称（引数1,引数2,・・・）が表示されますので、
　1行目以外は必須ではありません。
　解析結果を見やすくするためだけが目的のシートになります。
　 関数構文のサンプル
　（ほとんどの関数を入れています。）

複雑な計算式を解析する全VBAコード

シートモジュール（数式解析のシート）
　
Option Explicit
　Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　　Call AnalyzeFormula(Target)
　　　Cancel = True
　End Sub
　Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　　Call AnalyzeHighlight(Target)
　End Sub
　
BeforeDoubleClick
　数式をダブルクリックしたときに、AnalyzeFormula(Target)をCallます。
　数式解析のメイン処理です。
　 SelectionChange
　解析結果の数式をセル選択したときに、AnalyzeHighlight(Target)を呼びます。
　元の数式(B1)内で、選択セルの文字列と同じ文字列部分をハイライト（赤）表示します。
　 標準モジュール
　※以下のVBAコードは当初掲載以降に何度か修正しています。
　
Option Explicit
　 '元数式のセル
　Private Const oRange As String = "B1"
　 'ネストレベル管理列
　Private Const ctlCol As Integer = 1
　 '関数構文シート
　Private Const shFunc As String = "関数構文"
　 'ハイライトカラー
　Const HightLight1 As Long = XlRgbColor.rgbRed
　Const HightLight2 As Long = XlRgbColor.rgbBrown
　 '数式解析結果をクリア
　Public Sub AnalyzeClear()
　　　Application.ScreenUpdating = False
　　　Dim ws As Worksheet
　　　Set ws = ActiveSheet
　 '初期化：途中に空白行があるときも考慮
　　　Dim i1 As Long, i2 As Long
　　　i1 = ws.Range(oRange).Offset(1).Row
　　　i2 = ws.UsedRange(ws.UsedRange.Count).Row
　　　If i2 >= i1 Then
　　　　　ws.Range(ws.Rows(i1), ws.Rows(i2)).Delete
　　　End If
　 '元数式のセルの初期設定もここでやっておく
　 '先頭の=と改行があると邪魔なので消しておく
　　　Dim strCalc As String
　　　strCalc = ws.Range(oRange).Value
　　　If Left(strCalc, 1) = "=" Then strCalc = Mid(strCalc, 2)
　　　strCalc = Replace(Replace(strCalc, vbLf, ""), vbCr, "")
　　　ws.Range(oRange).Value = strCalc
　 '元数式のセルは式全体が見えるように行高調整
　　　Call ColumnFit(ws, ws.Range(oRange))
　 'Tagに初期値を入れておく：ControlのTagプロパティの代用
　　　Call setTag(ws.Range(oRange), 1)
　　　Application.ScreenUpdating = True
　End Sub
　 '数式を一気に全解析
　Public Sub AnalyzeAllFormula()
　　　Application.ScreenUpdating = False
　　　Dim ws As Worksheet
　　　Set ws = ActiveSheet
　 '元数式の解析だけ最初に行う
　　　Call AnalyzeFormula(ws.Range(oRange), False)
　 '解析結果に変化がなくなるまで
　　　Dim iLast1 As Long
　　　Dim iLast2 As Long
　　　Dim myRng1 As Range
　　　Dim myRng2 As Range
　　　iLast2 = ws.Cells(ws.Rows.Count, ctlCol).End(xlUp).Row
　　　Do Until iLast1 = iLast2
　　　　　iLast1 = iLast2
　　　　　Set myRng1 = Intersect(ws.UsedRange, _
　　　　　　　　　　　　　　　　 ws.Range(ws.Rows(ws.Range(oRange).Offset(1).Row), _
　　　　　　　　　　　　　　　　　　　　　ws.Rows(iLast1)))
　　　　　For Each myRng2 In myRng1
　 '速度アップのためここではじく
　　　　　　　If InStr(myRng2.Value, "(") > 0 Then
　　　　　　　　　Call AnalyzeFormula(myRng2, False)
　　　　　　　End If
　　　　　Next
　　　　　iLast2 = ws.Cells(ws.Rows.Count, ctlCol).End(xlUp).Row
　　　Loop
　　　Application.ScreenUpdating = True
　End Sub
　 '数式解析メイン処理：一番外側の関数のみ解析
　Public Sub AnalyzeFormula(ByVal Target As Range, _
　　　　　　　　　　　　　　Optional ByVal IsExpComp As Boolean = True)
　 '元計算式の場合のみ初期処理
　　　If Target.Item(1).Address = "$B$1" Then
　　　　　Call AnalyzeClear
　　　End If
　 '既に展開済み
　　　If ExpComp(Target, IsExpComp) Then
　　　　　Exit Sub
　　　End If
　 '関数が無ければ無視
　　　Dim strCalc As String
　　　strCalc = Target.Item(1).Value
　　　If InStr(strCalc, "(") = 0 Then '数式以外の列をクリックしたときの対応
　　　　　With Target.Worksheet
　　　　　　　Set Target = .Cells(Target.Row, .Columns.Count).End(xlToLeft)
　　　　　　　strCalc = Target.Item(1).Value
　　　　　End With
　　　End If
　　　If InStr(strCalc, "(") = 0 Then 'それでも関数がないときは抜ける
　　　　　Exit Sub
　　　End If
　 '入力数式から改行を削除
　　　strCalc = Replace(Replace(strCalc, vbLf, ""), vbCr, "")
　 '分解して配列に
　　　Dim i As Integer, j As Integer
　　　Dim ix As Integer
　　　Dim CntParen As Integer '始まり括弧の数
　　　Dim StartPos As Integer '処理文字位置
　 '引数を入れる配列：(0)関数名、(1)～引数
　 'ixが最後の引数のインデックスになります。
　 'ix+1に関数以降（+○）の数式を入れます。
　　　Dim OutAray(255) As String
　　　Dim OutAray2(255) As Integer '文字位置保存用
　　　Dim sTag As String
　　　sTag = getTag(Target)
　　　StartPos = 1
　　　i = 1
　　　ix = 0
　　　Do
　　　　　Select Case Mid(strCalc, i, 1)
　　　　　　　Case """" '次の"まで読み飛ばす
　　　　　　　　　i = i + 1
　　　　　　　　　Do Until Mid(strCalc, i, 1) = """"
　　　　　　　　　　　i = i + 1
　　　　　　　　　　　If i >= Len(strCalc) Then MsgBox "数式不正": Exit Sub
　　　　　　　　　Loop
　　　　　　　　　i = i + 1
　　　　　　　Case "'" '次の'まで読み飛ばす
　　　　　　　　　i = i + 1
　　　　　　　　　Do Until Mid(strCalc, i, 1) = "'"
　　　　　　　　　　　i = i + 1
　　　　　　　　　　　If i >= Len(strCalc) Then MsgBox "数式不正": Exit Sub
　　　　　　　　　Loop
　　　　　　　　　i = i + 1
　　　　　　　Case "(" '関数の引数始まり
　　　　　　　　　CntParen = CntParen + 1
　　　　　　　　　If CntParen = 1 Then '一番外の関数
　 '(0)固定で入れる
　　　　　　　　　　　OutAray(0) = Mid(strCalc, StartPos, i - StartPos)
　　　　　　　　　　　StartPos = i + 1
　　　　　　　　　End If
　　　　　　　　　i = i + 1
　　　　　　　Case ","
　　　　　　　　　If CntParen = 1 Then '一番外の関数内の引数
　　　　　　　　　　　ix = ix + 1
　　　　　　　　　　　OutAray(ix) = Mid(strCalc, StartPos, i - StartPos)
　　　　　　　　　　　OutAray2(ix) = sTag + StartPos - 1
　　　　　　　　　　　StartPos = i + 1
　　　　　　　　　End If
　　　　　　　　　i = i + 1
　　　　　　　Case ")"
　　　　　　　　　CntParen = CntParen - 1
　　　　　　　　　If CntParen = 0 Then '一番外の関数が括弧で閉じられた
　　　　　　　　　　　ix = ix + 1
　　　　　　　　　　　OutAray(ix) = Mid(strCalc, StartPos, i - StartPos)
　　　　　　　　　　　OutAray2(ix) = getTag(Target) + StartPos - 1
　　　　　　　　　　　StartPos = i + 1
　　　　　　　　　　　If i < Len(strCalc) Then
　 '関数()の後ろの文字列：ixカウントアップせず
　　　　　　　　　　　　　OutAray(ix + 1) = Mid(strCalc, StartPos)
　　　　　　　　　　　　　OutAray2(ix + 1) = getTag(Target) + StartPos - 1
　　　　　　　　　　　End If
　 '関数が終わったので出力
　　　　　　　　　　　Call PutArray(Target, OutAray, OutAray2, ix)
　　　　　　　　　　　Exit Do
　　　　　　　　　End If
　　　　　　　　　i = i + 1
　　　　　　　Case Else
　　　　　　　　　i = i + 1
　　　　　End Select
　 '文字列長を超えたら終了
　　　　　If i > Len(strCalc) Then Exit Do
　　　Loop
　 '数値が文字の「エラーを無視する」
　　　Call IgnoreNumberAsText(Target)
　End Sub
　 '元数式の、選択セルと同一数式部分をハイライト
　Public Sub AnalyzeHighlight(ByVal Target As Range)
　　　Application.ScreenUpdating = False
　 'シート取得しておく
　　　Dim sh As Worksheet
　　　Set sh = Target.Worksheet
　 '元数式の文字色を自動に戻す
　　　With sh.Range(oRange).Item(1)
　　　　　.Font.ColorIndex = xlAutomatic
　　　End With
　 '元数式セルまたはセル値ブランクは無視
　　　On Error Resume Next
　　　If Target.Item(1).Address = "$B$1" Or _
　　　　 Target.Item(1).Value = "" Or _
　　　　 Target.Count > 1 Then '行・列選択回避
　　　　　Application.ScreenUpdating = True
　　　　　Exit Sub
　　　End If
　 '元数式の当該数式部分をハイライト：
　　　Dim strValue As String
　　　Dim iPos As Integer
　　　Dim i As Integer
　　　strValue = Target.Item(1).Value
　 '同じ文字列があれば全てハイライト2：作業セル作りの参考になるので
　　　i = 1
　　　Do
　　　　　iPos = InStr(i, sh.Range(oRange).Value, strValue)
　　　　　If iPos = 0 Then Exit Do
　　　　　With sh.Range(oRange).Item(1)
　　　　　　　.Characters(Start:=iPos, Length:=Len(strValue)).Font.Color = HightLight2
　　　　　End With
　　　　　i = iPos + 1
　　　Loop
　 '当該数式をハイライト1
　　　i = getTag(Target)
　　　iPos = InStr(i, sh.Range(oRange).Value, strValue)
　　　If iPos = 0 Then Exit Sub
　　　With sh.Range(oRange).Item(1)
　　　　　.Characters(Start:=iPos, Length:=Len(strValue)).Font.Color = HightLight1
　　　End With
　　　Application.ScreenUpdating = True
　End Sub
　 '関数の引数出力
　Private Sub PutArray(ByVal Target As Range, _
　　　　　　　 ByRef OutAray() As String, _
　　　　　　　 ByRef OutAray2() As Integer, _
　　　　　　　 ByVal ix As Integer)
　 'シート取得しておく
　　　Dim sh As Worksheet
　　　Set sh = Target.Worksheet
　 '配列に入っていない場合は抜ける
　　　If ix = 0 Then Exit Sub
　 '括弧で始まっている場合は、括弧をとるだけ
　　　If OutAray(0) = "" Then
　　　　　Target = OutAray(1)
　　　　　Exit Sub
　　　End If
　 '必要行の追加
　　　sh.Rows(Target.Row + 1).Resize(ix).Insert
　 '挿入行の書式クリア
　　　With sh.Rows(Target.Row + 1).Resize(ix)
　　　　　.Clear
　　　　　.NumberFormatLocal = "@"
　　　　　.EntireRow.AutoFit
　　　End With
　　　Dim i As Integer, j As Integer
　　　Dim strFunc As String
　 '「関数構文」より引数名を取得
　　　On Error Resume Next
　　　j = WorksheetFunction.Match(GetFuncName(OutAray(0)), _
　　　　　　　　　　　　　　　　　Worksheets(shFunc).Columns(1), 0)
　　　If Err Then j = 1
　　　On Error GoTo 0
　 '配列(0)は関数名、(1)の引数から出力
　　　For i = 1 To ix
　　　　　With Target.Offset(i)
　　　　　　　.Value = Worksheets(shFunc).Cells(j, i + 1)
　　　　　　　If .Value = "" Then .Value = Worksheets(shFunc).Cells(1, i + 1)
　　　　　　　.Offset(, 1) = OutAray(i)
　　　　　　　sh.Cells(.Row, ctlCol) = Space(Target.Column) & Target.Column
　　　　　　　Call setTag(sh.Cells(.Row, ctlCol), OutAray2(i))
　　　　　End With
　　　Next
　 '関数外の数式がある場合
　　　If OutAray(ix + 1) <> "" Then
　　　　　sh.Rows(Target.Offset(ix + 1).Row).Insert
　　　　　With Target.Offset(ix + 1)
　　　　　　　.Value = "その他"
　　　　　　　.Offset(, 1) = OutAray(ix + 1)
　　　　　　　sh.Cells(.Row, ctlCol) = Space(Target.Column) & Target.Column
　　　　　　　Call setTag(sh.Cells(.Row, ctlCol), OutAray2(ix + 1))
　　　　　End With
　　　End If
　 '処理したセルはBold
　　　Target.Font.Bold = True
　 '配列を初期化
　　　ix = 0
　　　ReDim OutArray(100)
　End Sub
　 '解析結果の表示行の表示・非表示
　Private Function ExpComp(ByVal Target As Range, _
　　　　　　　　　　　　　　Optional ByVal IsExpComp As Boolean = True) As Boolean
　 'シート取得しておく
　　　Dim sh As Worksheet
　　　Set sh = Target.Worksheet
　 '行の折り畳み＆展開
　　　Dim sRow As Long
　　　Dim eRow As Long
　　　Dim iLevel As Integer
　　　Dim i As Long
　 '自身のネストレベル以上の連続範囲を取得
　　　iLevel = sh.Cells(Target.Row, ctlCol)
　　　sRow = Target.Row + 1
　　　i = sRow
　　　Do Until sh.Cells(i, ctlCol) <= iLevel Or sh.Cells(i, ctlCol) = ""
　　　　　eRow = i
　　　　　i = i + 1
　　　Loop
　 '自身のネストレベル以上があれば表示・非表示を切り替え
　　　If eRow >= sRow Then
　　　　　If Not IsExpComp Then
　　　　　　　ExpComp = True
　　　　　　　Exit Function
　　　　　End If
　　　　　sh.Range(sh.Rows(sRow), sh.Rows(eRow)).Hidden = _
　　　　　　　Not sh.Range(sh.Rows(sRow), sh.Rows(eRow)).Hidden
　　　　　ExpComp = True
　　　Else
　　　　　ExpComp = False
　　　End If
　End Function
　 '演算子等を除いて関数名の抜き出し
　Private Function GetFuncName(ByVal strFunc As String) As String
　　　Dim i As Integer
　　　For i = Len(strFunc) To 1 Step -1
　 '関数は"[A-Z]|."
　　　　　If (Mid(UCase(strFunc), i, 1) >= "A" And _
　　　　　　　Mid(UCase(strFunc), i, 1) <= "Z") Or _
　　　　　　　Mid(strFunc, i, 1) = "." Then
　　　　　Else
　　　　　　　strFunc = Mid(strFunc, i + 1)
　　　　　　　Exit For
　　　　　End If
　　　Next
　　　GetFuncName = UCase(strFunc)
　End Function
　 '結合セルの行高の自動調整
　Private Sub ColumnFit(ByVal sh As Worksheet, _
　　　　　　　　　　　　　ByVal Target As Range)
　　　Dim cWidth As Double '列幅：元
　　　Dim tWidth As Double '列幅：結合セル合計
　　　Dim rHeight As Double '行高
　　　Dim mCount As Integer '結合セル数
　　　Dim myRng As Range
　 '現在の状態を保存
　　　mCount = Target.Item(1).MergeArea.Count
　　　cWidth = sh.Columns(Target.Column).ColumnWidth
　　　For Each myRng In Target.Item(1).MergeArea
　　　　　tWidth = tWidth + sh.Columns(myRng.Column).ColumnWidth
　　　Next
　 '結合解除
　　　Target.MergeCells = False
　 '先頭セル幅を結合合計に
　　　sh.Columns(Target.Item(1).Column).ColumnWidth = tWidth
　 '行高自動調整
　　　sh.Rows(Target.Item(1).Row).AutoFit
　 '自動調整後の行高保存
　　　rHeight = sh.Rows(Target.Item(1).Row).rowHeight
　 '先頭セル幅を元に戻す
　　　sh.Columns(Target.Item(1).Column).ColumnWidth = cWidth
　 '再結合
　　　Target.Item(1).Resize(, mCount).MergeCells = True
　 '調整後の行高に設定
　　　sh.Rows(Target.Item(1).Row).rowHeight = rHeight
　End Sub
　 '数値が文字の「エラーを無視する」
　Private Sub IgnoreNumberAsText(ByVal Target As Range)
　　　Dim rng As Range
　　　For Each rng In Target.Worksheet.UsedRange
　　　　　If rng.Errors.Item(xlNumberAsText).Value Then
　　　　　　　rng.Errors(xlNumberAsText).Ignore = True
　　　　　End If
　　　Next
　End Sub
　 'ControlのTagプロパティの代用として
　Private Sub setTag(ByVal argRng As Range, ByVal argStr As String)
　　　With argRng.Item(1).Offset(, ctlCol - argRng.Column).Validation
　　　　　.Delete
　　　　　.Add xlValidateInputOnly
　　　　　.ErrorMessage = argStr
　　　End With
　End Sub
　Private Function getTag(ByVal argRng As Range) As Integer
　　　Dim strTag As String
　　　With argRng.Item(1).Offset(, ctlCol - argRng.Column).Validation
　　　　　strTag = .ErrorMessage
　　　End With
　　　If strTag = "" Or strTag = "0" Then strTag = 1
　　　getTag = CInt(strTag)
　End Function
外部から呼ばれる公開プロシージャーは4つです。
　'数式解析結果をクリア
　Public Sub AnalyzeClear()
　'数式を一気に全解析
　Public Sub AnalyzeAllFormula ()
　'数式解析メイン処理：一番外側の関数のみ解析
　Public Sub AnalyzeFormula (・・・)
　'元数式の、選択セルと同一数式部分をハイライト
　Public Sub AnalyzeHighlight(・・・)
　 AnalyzeFormula
　これが数式解析の心臓部です。
　ここで、一番外側の関数を引数に分解しています。
　分解結果は、Private Sub PutArrayでシートに出力 しています。
　 AnalyzeAllFormula
　AnalyzeFormulaを繰り返し呼ぶ事で一気に 全解析 するようにしているだけです。
　VBAを読むのに必要最低限のコメントは入れましたので、
　VBA内のコメントを頼りにVBAコードを読み解いてください。
　一番分かりづらいとしたら配列の部分だと思います。
　Dim OutAray(255) As String
　関数を分解して引数を入れる配列です。
　255というのは、Excel関数の引数の仕様上限数です。
　上限が決まっていて、かつ大きな数字ではないので静的配列にしました。
　とはいえ、そんなにたくさん引数を使っていたとしたら複雑とは別の問題がありますね。
　VBA内にも少し詳しくコメント入れましたが、
　'引数を入れる配列：(0)関数名、(1)～引数
　'ixが最後の引数のインデックスになります。
　'ix+1に関数以降（+○）の数式を入れます
　例えば、
　=IF(論理式,真の場合,偽の場合)+B1
　この場合は、 ixが3 になり
　(0)：IF
　(1)：論理式
　(2)：真の場合
　(3)：偽の場合
　(4)：+B1
　このように入ります。
　解析結果としては、
　すぐ下の行に4行挿入して、これらを引数名とともに出力します。
　下の方のPrivateのプロシージャーには、
　汎用的に使える記述もありますので参考にしてください。

複雑な計算式を解析した結果の表示


　 B1の数式：
　IF(A1<"A",VLOOKUP(A1,Sheet2!$A:$C,3,FALSE),
　OFFSET(Sheet3!$A$1,COUNTA(Sheet2!$A:$A),0,1,1))
　この数式は掲載用サンプルとして完全にデタラメな数式です。
　この程度の数式なら、ツールを使うまでもないのですが、雰囲気を伝えるためのものです。
　C3セルを選択しているので、B1セルの当該文字列が赤表示になっているのも見て取れるはずです。
　VBA内にコメントを入れましたが、同じ文字列があれば全てハイライトしています。
　これは同一数式が複数存在する場合は、それを作業セルにする時の参考になるという趣旨です。
　A列のネストレベルの最大値は4が表示されていますが、これは引数だけなので、
　実際の関数ネストとしては3重ネストということになります。
　これは、列数と同じ数字を列数分のスペースをいれて表示しているだけのものですが、
　解析結果を見るときの参考になると思い入れたものです。

最後に

最初に書きましたが、
　作業セル（計算セル）を使い、順序立ててわかるようにしておき、
　そもそもこんなツールが必要ないようにExcelを使うべきというのが基本原則になります。
　今回一番感じたのは、一見複雑に見えるものも、
　その成り立ちと自身の思考を、整理・単純化することが大切だということです。
　これはエクセルだけの話ではなく、全てに通じるものだと思います。
　※検証テストが不足しているので、バグがあった時ご報告いただければ幸いです。
　　（さすがに実務ではそうそう複雑な数式はないのでテスト材料が不足です）
　また、使ってみた感想などお送りいただければ励みになります。

Shift_JISのテキストファイルをUTF-8に一括変換

　本サイトの文字コードは開設当初からShift_JISでしたが、昨今の事情を考えてUTF-8に変更することにしました。
　そこで既存記事全てを一括で変換することになり、これをVBAでやりましたので、その時のマクロVBAコードを掲載しておきます。
　以下のVBAコードはサイトのUTF-8変更にあたり急遽作成したものですが、
　最低限の汎用化はしてありますので、概ねそのまま使えるはずです。
　 注意
　元ファイルを上書きしていますので、
　以下のVBAを使う時は、必ずバックアップをとるかフォルダ全体をコピーしてから実行してください。

マクロVBA全コード


　
Option Explicit
　Public objFSO As FileSystemObject
　Public objFolderSub As Folder
　Public objFile As File
　Sub SJIStoUTF8()
　 'フォルダ選択
　　　Dim strDir As String
　　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　　.InitialFileName = ThisWorkbook.Path
　　　　　.AllowMultiSelect = False
　　　　　.Title = "フォルダの選択"
　　　　　If .Show = False Then Exit Sub
　　　　　strDir = .SelectedItems(1)
　　　End With
　 '再帰処理のコール
　　　Set objFSO = New FileSystemObject
　　　Call GetSubDirFiles(objFSO.GetFolder(strDir))
　 'オブジェクトの解放
　　　Set objFSO = Nothing
　　　Set objFolderSub = Nothing
　　　Set objFile = Nothing
　 'ステータスバーを消去
　　　Application.StatusBar = False
　　　MsgBox "変換完了"
　End Sub
　Sub GetSubDirFiles(ByVal objFolder As Folder)
　　　Dim objFolderSub As Folder
　　　Dim objFile As File
　 'ステータスバーに処理中のフォルダを表示
　　　Application.StatusBar = objFolder.Path
　　　DoEvents
　 'ファイルの取得
　　　For Each objFile In objFolder.Files
　　　　　Application.StatusBar = objFile.Path
　　　　　DoEvents
　　　　　If objFSO.GetExtensionName(objFile) = " html " Then
　　　　　　　Call ReadSjisWiteUtf8(objFile.Path)
　　　　　End If
　　　Next
　 'サブフォルダの取得
　　　For Each objFolderSub In objFolder.SubFolders
　　　　　Call GetSubDirFiles(objFolderSub)
　　　Next
　End Sub
　Sub ReadSjisWiteUtf8(ByVal strFile As String)
　　　Dim txtBuf As String
　　　Dim byteData() As Byte
　　　Dim adoSt As New ADODB.Stream
　　　With adoSt
　 'Shift_JISで読込
　　　　　.Type = adTypeText
　　　　　.Charset = "Shift_JIS"
　　　　　.Open
　　　　　.LoadFromFile strFile
　　　　　txtBuf = .ReadText
　　　　　.Close
　 'UTF-8で保存
　　　　　.Charset = "UTF-8"
　　　　　.Open
　　　　　.WriteText txtBuf, adWriteChar
　 'BOM削除
　　　　　.Position = 0
　　　　　.Type = adTypeBinary
　　　　　.Position = 3
　　　　　byteData = .Read
　　　　　.Close
　　　　　.Open
　　　　　.Write byteData
　　　　　.SaveToFile strFile, adSaveCreateOverWrite
　　　　　.Close
　　　End With
　　　Set adoSt = Nothing
　End Sub
上記では、 事前バインディング として参照設定しています。
　VBAでActiveXオブジェクトを操作する場合のVBA記述方法が2通りあります。オブジェクトがオブジェクト変数に代入されるとき、事前 バインディングと遅延バインディング（実行時バインディング）の2通りです。バインディングとは バインディングはbindingで、縛るとか束ねると言う意味の英単語です。
　 FileSystemObject
　「ツール」→「参照設定」に、「Microsoft Scripting Runtime」にチェックを付けてください。
　参照設定しない場合は、
　Dim objFSO As Object
　Set objFSO = CreateObject("Scripting.FileSystemObject")
　 ADODB.Stream
　参照設定で、「Microsoft ActiveX Data Objects 2.8 Library」にチェックを付けて下さい。
　参照設定しない場合は、
　Dim adoSt As Object
　Set adoSt = CreateObject(ADODB.Stream)
　 拡張子の html は適宜変更 してください。

CSVの読み込み方法（ジャグ配列）

　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。
　当初作成して以来、ご要望をいただいたり自身で使っている中で、
　対応できないCSVが出てくるたびに改良を重ねています。
　今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。
　現在、本サイト内のCSV関連としては以下のページがあります。
　 VBAでのCSVの扱い方まとめ
　マクロVBAでCSVの読み書きする方法はいくつもあり、当サイトでも複数のページでそれぞれVBAコードを掲載しています。順次記事を掲載し ているので、それぞれどのような特徴があるかが良く分からなくなってしまっているようです。そこで、CSVに関するページをまとめておきました。
　 CSVの読み込み方法
　エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む ・ワークブックとして読み込む ・クエリーテーブルを使う ・ADOを使う ・PowerQueryを使う 大別するとこのようになります。この記事を書いた当初は、エクセルのVBAでCSVの読み込みについてネットで検索したところ、
　 CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 CSVの読み込み方法（改の改）
　CSVのVBAでの読込方法については複数の記事を掲載しており、人気記事として多くのアクセスがあります。掲載しているVBAコードは汎用的 に書いてあり、ほぼそのまま使用できるものです。しかし、CSVは多くの形式（区切り文字、文字コード等）があり、今まで掲載したコードでは解決出来ない ものがあります。
　 CSVの出力（書き出し）方法
　シート内容をCSV出力（書き出し）する方法です。CSVの読込は、「CSVの読込方法」「CSVの読込方法（改）」実施したいこと・ファイル 名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラムで区切ら ない。
　 UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…
　この中の、「CSVの読み込み方法（改の改）」で以下のように記載しました。

CSVの読み込み方法（改の改）での予告

配列を使ってシートにまとめて出力する場合

上記のマクロVBAでは、1フィールドごとにセルに出力しています。
　これは明らかに処理速度が遅くなってしまいます。
　（数万件くらいまでなら、そもそもそんなに時間もかかりませんが）
　ここは、一旦配列に入れておいて、最後にまとめてシートに出力したいところです。
　なのですが、
　世の中には、お行儀のよいCSVばかりではありません。
　行によって列数（つまりカンマの区切り数）が不定となっているようなものもあったりします。
　先頭行は10列ではじまっているのに、途中から12列になっていたりという事です。
　このようなCSVにおいては列数を事前に決められない為、配列を用意するのが難しくなります。
　これらに対応するには、列数を多めにとった配列を用意するか、
　一旦ジャグ配列（要素も配列である配列）として確保して、最後に2次元配列に入れ直してからシートに出力する等の工夫が必要です。
　・列数が決まっていれば、その列数で配列を用意
　・列数不明の時は、1行目の列数取得後に配列を用意
　・列数不定の場合は、ジャグ配列で処理
　以上のどれかで対応することになります。
　下に行くにしたがって、VBAの難易度は上がっていきます。
　上記VBAの主な変更点は、
　・CsvInTextで配列を用意
　・PutCellの
　　ws.Cells(i, j) = strCell
　　このws.Cells(i, j)を配列に変更
　固定列数であれば、そんなに多くの修正は必要ないと思います。
　配列の行数は最初は少し大きめに確保しておいて、行数が足らなくなったらRedim Preserveで確保すれば良いでしょう。
　このような面倒な処理の必要性がないのは、シートのセルを直接利用する最大の利点ともいえます。
　興味のある方は、ぜひ配列化にチャレンジしてみてください。
　要望があり機会があれば、当サイトでも公開しようと思います。

CSV読み込みでのジャグ配列の使いどころ

直接セルに出力したからと言って、そんなに遅いという事はありません。
　そもそも所要時間の半分近くは、ファイルからのデータ読み込み部分になるからです。
　特にUTF-8で改行がLFになっている場合と、Windows標準のCRLFのCSVを共通で処理しているため、
　データとしてのLFと改行としてのLFの区別をつけるために、行ごとの読み込みが必要となっています。
　この部分の処理時間を短縮するには、
　ある程度決め打ち（UTF-8専用とか、データ内にLFが無いとか）しないとかなり難しいVBAになると思います。
　今回はファイルからデータ読み込んだ後のセルへの出力方法のみ変更しています。
　1セル毎ではなく、一旦配列に入れてから一括でシートに出力するようにして時簡短縮を図っています。
　ですが、
　結果から言うと、計測してみた限りではさほど変わりませんでした。
　確かに速くはなっていますが、数MBのCSVでは時間を測ってみないと分からない程度の違いです。
　4MB程度のCSVで試したところ、
　前が9秒くらいで、今回が7秒くらい、
　まあ早くはなっていますが、、、
　そもそもデータ読み込みに3秒以上かかっているので仕方ないところではあります。
　CSVの列数が不定（1つのファイル内において行ごとに列数が違う）の場合の対応としてジャグ配列を使います。
　CSVの行を1次元配列として、
　その1行の要素の中に、1フィールドごとの1次元配列を入れます。
　 このようなイメージになります。
　ただし、このままではワークシートのセルにまとめて出力することができないので、
　2次元配列（行数×最大列数）に入れ直してから、ワークシートに出力しています。
　※配列は1スタートで作成しています。
　CSVを読み込む基本部分は、「CSVの読み込み方法（改の改）」と変更がありません。
　あくまで、セル出力の部分を配列に変更したものになります。
　CSV→ジャグ配列→2次元配列→シート
　このような順で処理しているので、必要に応じてと途中の配列を使う事が出来ます。
　シートに出力せずに処理するような場合には色々と活用できるのではないでしょうか。

CSV読み込みVBAコード：ジャグ配列バージョン


　
Option Explicit
　 '使用例
　Sub sample1()
　　　Dim ws As Worksheet
　　　Dim sFile As String
　　　sFile = "csvのフルパス"
　 '出力シート
　　　Set ws = ActiveSheet
　　　ws.Cells.Clear
　 '以下では全列を文字に設定
　 '数値も文字としてセルに入ります
　 '文字設定にしなければ数値は数値として入ります。
　　　ws.Cells.NumberFormatLocal = "@"
　　　Application.ScreenUpdating = False
　 'CSV取込
　　　Call CsvToSheet(ws, sFile)
　 'utf-8決め打ちで読み込む場合は以下で
　 'Call CsvToSheet(ws, sFile, "utf-8")
　　　Application.ScreenUpdating = True
　End Sub
　Public Sub CsvToSheet(ByVal ws As Worksheet, _
　　　　　　　　　　　　ByVal strFile As String, _
　　　　　　　　　　　　Optional ByVal CharSet As String = "Auto")
　　　Dim myArray() As Variant
　 'readCsvでCSVを読み込み
　　　Dim strRec As String
　　　strRec = readCsv(strFile, CharSet)
　 'CsvToJaggedで行・フィールドに分割してジャグ配列に
　　　Dim jagArray() As Variant
　　　jagArray = CsvToJagged(strRec)
　 'JaggedTo2Dでジャグ配列を2次元配列に変換
　　　Call JaggedTo2D(jagArray, myArray)
　 '上記を全てネストすれば以下で書けますが、お勧めはしません。
　 'Call JaggedTo2D(CsvToJagged(readCsv(strFile, CharSet)), myArray)
　 '2次元配列→シート
　　　ws.Range("A1").Resize(UBound(myArray, 1), UBound(myArray, 2)) = myArray
　End Sub
　Private Sub JaggedTo2D(ByRef jagArray() As Variant, _
　　　　　　　　　　　　 ByRef twoDArray As Variant)
　 'ジャグ配列の最大列数取得
　　　Dim maxCol As Long, v As Variant
　　　maxCol = 0
　　　For Each v In jagArray
　　　　　If UBound(v) > maxCol Then
　　　　　　　maxCol = UBound(v)
　　　　　End If
　　　Next
　 'ジャグ配列→2次元配列
　　　Dim i1 As Long, i2 As Long
　　　ReDim twoDArray(1 To UBound(jagArray), 1 To maxCol)
　　　For i1 = 1 To UBound(jagArray)
　　　　　For i2 = 1 To UBound(jagArray(i1))
　　　　　　　twoDArray(i1, i2) = jagArray(i1)(i2)
　　　　　Next
　　　Next
　End Sub
　Private Function CsvToJagged(ByVal strRec As String) As Variant()
　　　Dim childArray() As Variant 'ジャグ配列の子配列
　　　Dim lngQuate As Long 'ダブルクォーテーション数
　　　Dim strCell As String '1フィールド文字列
　　　Dim blnCrLf As Boolean '改行判定
　　　Dim i As Long '行位置
　　　Dim j As Long '列位置
　　　Dim k As Long
　　　ReDim CsvToJagged(1 To 1) 'ジャグ配列の初期化
　　　ReDim childArray(1 To 1) 'ジャグ配列の子配列の初期化
　　　i = 1 'シートの1行目から出力
　　　j = 0 '列位置はputChildArrayでカウントアップ
　　　lngQuate = 0 'ダブルクォーテーションの数
　　　strCell = ""
　　　For k = 1 To Len(strRec)
　　　　　Select Case Mid(strRec, k, 1)
　　　　　　　Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　blnCrLf = False
　　　　　　　　　　　If k > 1 Then '改行のCrLfはCrで改行判定済なので無視する
　　　　　　　　　　　　　If Mid(strRec, k - 1, 2) = vbCrLf Then
　　　　　　　　　　　　　　　blnCrLf = True
　　　　　　　　　　　　　End If
　　　　　　　　　　　End If
　　　　　　　　　　　If blnCrLf = False Then
　　　　　　　　　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　 'これが改行となる
　　　　　　　　　　　　　Call putjagArray(CsvToJagged, childArray, _
　　　　　　　　　　　　　　　　　　　　　 i, j, lngQuate, strCell)
　　　　　　　　　　　End If
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case ",", vbTab '「"」が偶数なら区切り、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case """" '「"」のカウントをとる
　　　　　　　　　lngQuate = lngQuate + 1
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　Case Else
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　End Select
　　　Next
　 '最終行の最終列の処理
　　　If j > 0 And strCell <> "" Then
　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　　　　　Call putjagArray(CsvToJagged, childArray, _
　　　　　　　　　　　　　 i, j, lngQuate, strCell)
　　　End If
　End Function
　Private Sub putjagArray(ByRef jagArray() As Variant, _
　　　　　　　　　　　　　ByRef childArray() As Variant, _
　　　　　　　　　　　　　ByRef i As Long, _
　　　　　　　　　　　　　ByRef j As Long, _
　　　　　　　　　　　　　ByRef lngQuate As Long, _
　　　　　　　　　　　　　ByRef strCell As String)
　　　If i > UBound(jagArray) Then '常に成立するが一応記述
　　　　　ReDim Preserve jagArray(1 To i)
　　　End If
　　　jagArray(i) = childArray '子配列をジャグ配列に入れる
　　　ReDim childArray(1 To 1) '子配列の初期化
　　　i = i + 1 '列位置
　　　j = 0 '列位置
　　　lngQuate = 0 'ダブルクォーテーション数
　　　strCell = "" '1フィールド文字列
　End Sub
　 '1フィールドごとにセルに出力
　Private Sub putChildArray(ByRef childArray() As Variant, _
　　　　　　　　　　　　　　ByRef j As Long, _
　　　　　　　　　　　　　　ByRef strCell As String, _
　　　　　　　　　　　　　　ByRef lngQuate As Long)
　　　j = j + 1
　 '「""」を「"」で置換
　　　strCell = Replace(strCell, """""", """")
　 '前後の「"」を削除
　　　If Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
　　　　　If Len(strCell) <= 2 Then
　　　　　　　strCell = ""
　　　　　Else
　　　　　　　strCell = Mid(strCell, 2, Len(strCell) - 2)
　　　　　End If
　　　End If
　　　If j > UBound(childArray) Then
　　　　　ReDim Preserve childArray(1 To j)
　　　End If
　　　childArray(j) = strCell
　　　strCell = ""
　　　lngQuate = 0
　End Sub
　 '文字コードを自動判別し、全行をCrLf区切りに統一してStringに入れる
　Private Function readCsv(ByVal strFile As String, _
　　　　　　　　　　　　　 ByVal CharSet As String) As String
　　　Dim objFSO As New FileSystemObject
　　　Dim inTS As TextStream
　　　Dim adoSt As New ADODB.Stream
　　　Dim strRec As String
　　　Dim i As Long
　　　Dim aryRec() As String
　　　If CharSet = "Auto" Then CharSet = getCharSet(strFile)
　　　Select Case LCase(CharSet)
　　　　　Case "unicode", "unicodefeff"
　 'TristateTrueで読込
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile, ForReading, , TristateTrue)
　　　　　　　strRec = inTS.ReadAll
　　　　　　　inTS.Close
　　　　　Case "utf-8"
　 'ADOを使って読込、その後の処理を統一するため全レコードをCrLfで結合
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile, ForAppending)
　　　　　　　i = inTS.Line - 1
　　　　　　　inTS.Close
　　　　　　　ReDim aryRec(i)
　　　　　　　With adoSt
　　　　　　　　　.Type = adTypeText
　　　　　　　　　.CharSet = "UTF-8"
　　　　　　　　　.Open
　　　　　　　　　.LoadFromFile strFile
　　　　　　　　　i = 0
　　　　　　　　　Do While Not (.EOS)
　　　　　　　　　　　aryRec(i) = .ReadText(adReadLine)
　　　　　　　　　　　i = i + 1
　　　　　　　　　Loop
　　　　　　　　　.Close
　　　　　　　　　strRec = Join(aryRec, vbCrLf)
　　　　　　　End With
　　　　　Case Else
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile, ForReading)
　　　　　　　strRec = inTS.ReadAll
　　　　　　　inTS.Close
　　　End Select
　　　Set inTS = Nothing
　　　Set objFSO = Nothing
　　　readCsv = strRec
　End Function
　 '文字コードの自動判別
　 'UTF-8のBOMなしは文字コードの判別に対応できていません。
　Private Function getCharSet(ByVal sFile As String) As String
　　　Dim objHtml As MSHTML.HTMLDocument
　　　Dim strRec As String
　 'GetObjectでHTMLDocumentを生成し、文字コードを判定する
　　　Set objHtml = GetObject(sFile, "htmlfile")
　　　Do While objHtml.readyState <> "complete"
　　　　　DoEvents
　　　Loop
　　　getCharSet = objHtml.CharSet
　　　Set objHtml = Nothing
　End Function
参照設定
　Microsoft Scripting Runtime
　Microsoft ActiveX Data Objects x.x Library
　Microsoft Html Object Library
　VBAコードについては解説しきれないので、
　コード内のコメントを参考にしてください。

最後に

CSVを読み込む方法は多種多様にありますが、
　この記事を書いた当初は、
　エクセルのマクロVBAでCSVの読み込みについてネットで検索したところ、なかなか良いものが見つかりませんでした。
　それならということで、CSVの読み込みのマクロVBAを作成しました。
　それ以来改良を何度か重ねた結果が今回のものとなっています。
　VBAコードは、常に引き継いでいるので、冗長な部分もあると思いますが、
　旧バージョンを使い、独自に変更を加えている人にとっては、
　新バージョンでは、なるべく旧バージョンのVBAコードが継承されている方が良いだろうという理由もあります。
　掲載しているVBAは当然そのままでも動作しますが、
　独自にアレンジを加えて使用したり、そもそもVBA学習の素材として使ってもらう事を目的としています。
　 後日追記
　文字コード判定で、UTF-8Nが判定できていないという課題が残っています。
　文字コードの判定を全て完璧に行うのは無理ですが、簡易的にでもUTF-8Nを判定したいところです。
　そこで、きわめて簡易的ではありますが、これに対応するVBAを書いてみました。
　また、使うにあたって参照設定が面倒な場合もあるので、参照設定せずにCreateObjectに変更しています。
　 CSVの読み込み方法（ジャグ配列）（改）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。順次改定していくつかのバージョンが存在します。最新のジャグ配列（配列の配列）で読み込むVBAについて、UTF-8Nの文字コード判別の課題が残っていました。

VBAコードの全プロシージャー・プロパティ一覧を取得

　VBAの開発規模がある程度大きくなってくると、VBAソース管理の必要性を感じることもあると思います。
　モジュールの数も増えてきて、プロシージャー・プロパティが膨大になってきます。
　以下は、指定ブックの全モジュールの全プロシージャー・プロパティを一覧にするVBAサンプルです。
　SubまたはFunctionプロシージャ、Property Get,Let,Setの種別や、プロシージャ等の直前コメントも取得するようにしています。

セキュリティについて

VBAでVBAプロジェクトを扱う為には、以下の設定が必要になります。
　「ファイル」→「オプション」→「セキュリティ センター」→「セキュリティ センターの設定」→「マクロの設定」
　 この「VBA プロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを付けてください。
　ただし、セキュリティを弱くするので、
　このようなVBAを実行するとき以外は、チェックを外しておくことをお勧めします。
　このチェックを付けずに今回のVBAを実行すると以下のエラーとなります。
　

VBAコードの全プロシージャー・プロパィ一覧を取得するVBAコード

標準モジュール
　
'Dictionaryにプロシージャー・プロパティ情報を格納
　Public Sub getCodeModule(ByRef dicProcInfo As Dictionary, _
　　　　　　　　　　　　　 ByVal wb As Workbook, _
　　　　　　　　　　　　　 ByVal sMod As String)
　　　Dim cProcInfo As clsProcInfo
　　　Dim sProcName As String
　　　Dim sProcKey As String
　　　Dim iProcKind As Long
　　　Dim i As Long
　　　Dim VVC As Object
　　　Set VVC = wb.VBProject.VBComponents(sMod).CodeModule
　　　i = 1
　　　Do While i <= VVC.CountOfLines
　　　　　sProcName = VVC.ProcOfLine(i, iProcKind)
　　　　　sProcKey = sMod & "." & sProcName
　　　　　If sProcName <> "" Then
　　　　　　　If isProcLine(VVC.Lines(i, 1), sProcName) Then
　　　　　　　　　If Not dicProcInfo.Exists(sProcKey) Then
　　　　　　　　　　　Set cProcInfo = New clsProcInfo
　　　　　　　　　　　cProcInfo.ModName = sMod
　　　　　　　　　　　cProcInfo.ProcName = sProcName
　　　　　　　　　　　cProcInfo.ProcKind = iProcKind
　　　　　　　　　　　cProcInfo.LineNo = i
　　　　　　　　　　　cProcInfo.Comment = getProcComment(i, VVC)
　　　　　　　　　　　cProcInfo.Source = getProcSource(i, VVC)
　　　　　　　　　　　dicProcInfo.Add sProcKey, cProcInfo
　　　　　　　　　End If
　　　　　　　End If
　　　　　End If
　　　　　i = i + 1
　　　Loop
　End Sub
　 'プロシージャー・プロパティ定義行かの判定
　Private Function isProcLine(ByVal strLine As String, _
　　　　　　　　　　　　　　　ByVal ProcName As String) As Boolean
　　　strLine = " " & Trim(strLine)
　　　Select Case True
　　　　　Case Left(strLine, 1) = " '"
　　　　　　　isProcLine = False
　　　　　Case strLine Like "* Sub " & ProcName & "(*"
　　　　　　　isProcLine = True
　　　　　Case strLine Like "* Sub " & ProcName & " _"
　　　　　　　isProcLine = True
　　　　　Case strLine Like "* Function " & ProcName & "(*"
　　　　　　　isProcLine = True
　　　　　Case strLine Like "* Function " & ProcName & " _"
　　　　　　　isProcLine = True
　　　　　Case strLine Like "* Property * " & ProcName & "(*"
　　　　　　　isProcLine = True
　　　　　Case strLine Like "* Property * " & ProcName & " _"
　　　　　　　isProcLine = True
　　　　　Case Else
　　　　　　　isProcLine = False
　　　End Select
　End Function
　 '継続行( _)全てを連結した文字列で返す
　Private Function getProcSource(ByRef i As Long, _
　　　　　　　　　　　　　　　　 ByVal aCodeModule As Object) As String
　　　getProcSource = ""
　　　Dim sTemp As String
　　　Do
　　　　　sTemp = Trim(aCodeModule.Lines(i, 1))
　　　　　If Right(aCodeModule.Lines(i, 1), 2) = " _" Then
　　　　　　　sTemp = Left(sTemp, Len(sTemp) - 1)
　　　　　End If
　　　　　getProcSource = getProcSource & sTemp
　　　　　If Right(aCodeModule.Lines(i, 1), 2) <> " _" Then Exit Do
　　　　　i = i + 1
　　　Loop
　End Function
　 'プロシージャーの直前のコメントを取得
　Private Function getProcComment(ByVal i As Long, _
　　　　　　　　　　　　　　　　　ByVal aCodeModule As Object) As String
　　　getProcComment = ""
　　　i = i - 1
　　　Do While Left(aCodeModule.Lines(i, 1), 1) = "'"
　　　　　If getProcComment <> "" Then getProcComment = vbLf & getProcComment
　　　　　getProcComment = aCodeModule.Lines(i, 1) & getProcComment
　　　　　i = i - 1
　　　Loop
　End Function
クラスモジュール：clsProcInfo
　
Option Explicit
　Public ModName As String
　Public ProcName As String
　Public ProcKind As String
　Public LineNo As Long
　Public Source As String
　Public Comment As String
　Public Property Get ProcKindName() As String
　　　Select Case ProcKind
　　　　　Case 0
　　　　　　　ProcKindName = "Sub Function"
　　　　　Case 1
　　　　　　　ProcKindName = "Property Let"
　　　　　Case 2
　　　　　　　ProcKindName = "Property Set"
　　　　　Case 3
　　　　　　　ProcKindName = "Property Get"
　　　End Select
　End Property
　Public Property Get Scope() As String
　　　Select Case True
　　　　　Case Trim(Source) Like "Private *"
　　　　　　　Scope = "Private"
　　　　　Case Trim(Source) Like "Friend *"
　　　　　　　Scope = "Friend"
　　　　　Case Trim(Source) Like "Static *"
　　　　　　　Scope = "Static"
　　　　　Case Else
　　　　　　　Scope = "Public"
　　　End Select
　End Property
参照設定
　「ツール」→「参照設定」で、
　Microsoft Scripting Runtime
　これを参照設定して下さい。
　参照設定しない場合は、
　dicProcInfo As Object
　としてください。
　 概要
　プロシージャー・プロパティの一覧はDictionaryに入れています。
　「getCodeModule」がメインの関数で、他はその中で使用している関数になります。
　「プロシージャー・プロパティ定義行かの判定」が面倒な記述になっていますが、
　以下のような紛れをなるべく除くための記述になります。
　・プロシージャー名直後の改行
　・コメント内でのプロシージャー名
　・プロシージャーのCall
　・プロパテイへの値設定・取得
　いろいろなパターンがあり、今回のコードでも漏れがあるかもしれません。
　正規表現を使ったりしたより良い判定方法もあると思います。
　必要に応じて、適宜修正して使用してください。
　コメントは、
　プロシージャー・プロパティ直前に連続記述されているもののみ対象としています。
　Dictionaryにしているので、
　シートに出力するだけではなく、その他の用途でも使いやすいと思います。
　Dictionaryのキーは、「モジュール名.プロシージャー名」にしていますので、簡単に検索できるはずです。
　 クラス使用の理由
　ユーザー定義型(Type)はDictionaryやCollectionに入れられません。
　そこで、ユーザー定義型の代わりにクラスを使用することで独自データ型を定義しています。
　クラスにすることで、プロパティでさらに情報の操作が可能となり融通が効くようになります。

使用する場合のVBAサンプル

シートに全プロシージャー・プロパティ一覧を出力します。
　どこでも良いですが、基本としては標準モジュールで使用することを想定しています。
　
Private Sub sample()
　　　Dim dicProcInfo As New Dictionary
　　　Dim wb As Workbook
　　　Set wb = ThisWorkbook
　　　Dim i As Long
　 'ブックの全モジュールを処理
　　　With wb.VBProject
　　　　　For i = 1 To .VBComponents.Count
　　　　　　　Call getCodeModule(dicProcInfo, wb, .VBComponents(i).Name)
　　　　　Next
　　　End With
　 'Dictionaryよりシートに出力
　　　Dim ws As Worksheet
　　　Set ws = ThisWorkbook.Worksheets("プロシーシャー一覧")
　　　Dim v
　　　With ws
　　　　　.Cells.Clear
　　　　　.Range("A1:G1").Value = Array("モジュール", "プロシージャー", "スコープ", "種別", "行位置", "ソース", "コメント")
　　　　　i = 2
　　　　　For Each v In dicProcInfo.Items
　　　　　　　.Cells(i, 1) = v.ModName
　　　　　　　.Cells(i, 2) = v.ProcName
　　　　　　　.Cells(i, 3) = v.Scope
　　　　　　　.Cells(i, 4) = v.ProcKindName
　　　　　　　.Cells(i, 5) = v.LineNo
　　　　　　　.Cells(i, 6) = v.Source
　　　　　　　.Cells(i, 7) = "'" & v.Comment
　　　　　　　i = i + 1
　　　　　Next
　　　End With
　　　Set dicProcInfo = Nothing
　End Sub
参照設定
　「ツール」→「参照設定」で、
　Microsoft Scripting Runtime
　これを参照設定して下さい。
　参照設定しない場合は、
　Dim dicProcInfo As Object
　Set dicProcInfo = CreateObject("Scripting.Dictionary")
　として下さい。
　シートへの出力結果は以下のようになります。
　 これだけでも使えますが、
　さらに独自の項目を追加して機能拡張してみると良いのではないでしょうか。

VBAでのCSVの扱い方まとめ

　マクロVBAでCSVの読み書きする方法はいくつもあり、当サイトでも複数のページでそれぞれVBAコードを掲載しています。
　順次記事を掲載しているので、それぞれどのような特徴があるかが良く分からなくなってしまっているようです。
　そこで、CSVに関するページをまとめておきました。

本サイトにあるCSV関連記事一覧

CSVの読込方法
　エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む ・ワークブックとして読み込む ・クエリーテーブルを使う ・ADOを使う ・PowerQueryを使う 大別するとこのようになります。この記事を書いた当初は、エクセルのVBAでCSVの読み込みについてネットで検索したところ、
　 CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 CSVの読み込み方法（改の改）
　CSVのVBAでの読込方法については複数の記事を掲載しており、人気記事として多くのアクセスがあります。掲載しているVBAコードは汎用的 に書いてあり、ほぼそのまま使用できるものです。しかし、CSVは多くの形式（区切り文字、文字コード等）があり、今まで掲載したコードでは解決出来ない ものがあります。
　 CSVの読み込み方法（ジャグ配列）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。当初作成して以来、ご要望をいただいたり自身で 使っている中で、対応できないCSVが出てくるたびに改良を重ねています。今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。
　 CSVの読み込み方法（ジャグ配列）（改）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。順次改定していくつかのバージョンが存在します。最新のジャグ配列（配列の配列）で読み込むVBAについて、UTF-8Nの文字コード判別の課題が残っていました。
　 CSVの出力（書き出し）方法
　シート内容をCSV出力（書き出し）する方法です。CSVの読込は、「CSVの読込方法」「CSVの読込方法（改）」実施したいこと・ファイル 名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラムで区切ら ない。
　 UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…
　 ADOでCSVの読み込み（SQL）
　VBAでADOを使用し、CSVデータを読み込みます。ADOではSQL文が必要になりますが、ここではSQL文の詳細については説明を省略します。ADO以外の方法については、「CSVの読み込み方法」を参考にして下さい。
　以下で簡単に内容を紹介します。

CSVの読込方法

CSVの読込方法
　エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む ・ワークブックとして読み込む ・クエリーテーブルを使う ・ADOを使う ・PowerQueryを使う 大別するとこのようになります。この記事を書いた当初は、エクセルのVBAでCSVの読み込みについてネットで検索したところ、
　エクセルのマクロVBAでのCSVの読込方法としては。
　・テキストファイルとして読み込む
　・ワークブックとして読み込む
　・クエリーテーブルを使う
　・ADOを使う
　・Power Queryを使う
　大別するとこのようになります。
　このページでは、以下について解説及びVBAコードを掲載しています。

もっとも簡単かつ良くあるCSV読み込みVBAコード

「,」「"」に対応したCSV読み込みVBAコード

CSVをExcelブックとして開くVBA

クエリーテーブルを使ったCSV読み込みVBAコード

CSVの読み込み方法（改）

CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 CSVの読込方法
　エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む ・ワークブックとして読み込む ・クエリーテーブルを使う ・ADOを使う ・PowerQueryを使う 大別するとこのようになります。この記事を書いた当初は、エクセルのVBAでCSVの読み込みについてネットで検索したところ、
　これに対して、以下の要望を受けて対応をしたVBAになります。
　・ファイル名を指定し、形式をカンマ区切り、文字列で開く
　・その際、改行コードLF、CRLF、CRいずれにも対応
　・セル内の","や改行についてはカラムで区切らない

CSVの読み込み方法（改の改）

CSVの読み込み方法（改の改）
　CSVのVBAでの読込方法については複数の記事を掲載しており、人気記事として多くのアクセスがあります。掲載しているVBAコードは汎用的 に書いてあり、ほぼそのまま使用できるものです。しかし、CSVは多くの形式（区切り文字、文字コード等）があり、今まで掲載したコードでは解決出来ない ものがあります。

CSVの形式について

区切り文字
　 カンマ区切り
　 タブ区切り
　 文字コード
　 Shit-JIS
　 UTF-8
　 Unicode
　 Unicode big endian
　結果として、上記の区切り文字と文字コードの組み合わせが存在することになります。
　全ての組み合わせで処理可能なVBAコードを作ることが目的です。
　 CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…
　これらのページで掲載しているVBAコードを改造し、
　テキストの文字コードを判定を加えたものです。

CSVの読み込み方法（ジャグ配列）

CSVの読み込み方法（ジャグ配列）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。当初作成して以来、ご要望をいただいたり自身で 使っている中で、対応できないCSVが出てくるたびに改良を重ねています。今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。
　一旦ジャグ配列（配列の配列）に入れてからシートに出力するCSV読み込み方法になります。
　以下の予告をもとに作成したVBAコードを公開したページになります。
　 CSVの読み込み方法（改の改） での予告
　 配列を使ってシートにまとめて出力する場合
　上記のマクロVBAでは、1フィールドごとにセルに出力しています。
　これは明らかに処理速度が遅くなってしまいます。
　（数万件くらいまでなら、そもそもそんなに時間もかかりませんが）
　ここは、一旦配列に入れておいて、最後にまとめてシートに出力したいところです。
　なのですが、
　世の中には、お行儀のよいCSVばかりではありません。
　行によって列数（つまりカンマの区切り数）が不定となっているようなものもあったりします。
　先頭行は10列ではじまっているのに、途中から12列になっていたりという事です。
　このようなCSVにおいては列数を事前に決められない為、配列を用意するのが難しくなります。
　これらに対応するには、列数を多めにとった配列を用意するか、
　一旦ジャグ配列（要素も配列である配列）として確保して、最後に2次元配列に入れ直してからシートに出力する等の工夫が必要です。
　・列数が決まっていれば、その列数で配列を用意
　・列数不明の時は、1行目の列数取得後に配列を用意
　・列数不定の場合は、ジャグ配列で処理
　以上のどれかで対応することになります。
　下に行くにしたがって、VBAの難易度は上がっていきます。
　上記VBAの主な変更点は、
　・CsvInTextで配列を用意
　・PutCellの
　　ws.Cells(i, j) = strCell
　　このws.Cells(i, j)を配列に変更
　固定列数であれば、そんなに多くの修正は必要ないと思います。
　配列の行数は最初は少し大きめに確保しておいて、行数が足らなくなったらRedim Preserveで確保すれば良いでしょう。
　このような面倒な処理の必要性がないのは、シートのセルを直接利用する最大の利点ともいえます。
　興味のある方は、ぜひ配列化にチャレンジしてみてください。
　要望があり機会があれば、当サイトでも公開しようと思います。

CSVの読み込み方法（ジャグ配列）（改）

CSVの読み込み方法（ジャグ配列）（改）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。順次改定していくつかのバージョンが存在します。最新のジャグ配列（配列の配列）で読み込むVBAについて、UTF-8Nの文字コード判別の課題が残っていました。
　CSVの読み込み方法（ジャグ配列）では、UTF-8Nの文字コード判別の課題が残っていました。
　そこで、
　文字コードの判定を全て完璧に行うのは無理ですが、簡易的にでもUTF-8Nを判定したいところです。
　そこで、きわめて簡易的ではありますが、これに対応するVBAを書いてみました。
　また、使うにあたって参照設定が面倒な場合もあるので、参照設定せずにCreateObjectに変更しています。
　文字コードの判定は、これで完璧ということではありません。
　SHIFT_JISで使われていてUTF-8で使われていないと思われる文字コードの範囲を判定しています。
　つまり、SHIFT_JISと判定できる場合以外は、UTF-8という事にしています。

CSVの出力（書き出し）方法

CSVの出力（書き出し）方法
　シート内容をCSV出力（書き出し）する方法です。CSVの読込は、「CSVの読込方法」「CSVの読込方法（改）」実施したいこと・ファイル 名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラムで区切ら ない。

まずは、エクセルの機能をそのまま利用します。

しかし、これでは、いろいろ不都合な場合があります。
　他システム、特にDB等へアップロードする場合には、このままでは出来ない事があるのです。
　例えば、日付は、表示形式のままの文字列で出力されてしまいます。
　また数値もカンマ付の場合は、"12,345"のように、文字列として出力されます。
　CSV出力前に、当該シートの書式を全て直してから行えばよいのですが、
　書式の変更も面倒なら、また元に戻す必要があり、何かと不都合です。

このような場合は、直接CSVを出力するようにします。

「最終行取得」、「最終列取得」は以前に作成済のモジュールです。
　行列がでこぼこに入力されている場合でも、正しく最終判定をする為に使用しています。
　通常の一覧なら、End(xlUp)等でも良いでしょう。
　 FileSystemObjectを使用していますが 、昔からある、
　 Open ファイル For Output As # 1
　でも良いです。

UTF-8でCSVの読み書き（ADODB.Stream）

UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…
　VBAで UTF-8 を扱う為には、 ADODB.Stream を使う必要があります。

アクティブシートの内容をUTF-8でCSV出力します。

シートのUsedRangeをCSV出力しています。
　※本記事を掲載後に、BOM無しのUTF8(UTF8N)でCSVを作成することがありましたので追記します。
　このようにすることで、BOM無し(UTF8N)でCSVを作成できます。

UTF-8のCSVを行単位で読込、アクティブシーヘ書き出しています。

ADODB.Streamのメソッドとプロパティ
　 Open メソッドを使って、Record または URL から Stream を開きます。
　 Close メソッドを使って、Stream を閉じます。
　 Write メソッドまたは WriteTex t メソッドを使って、バイトまたはテキストを Stream に入力します。
　 Read メソッドまたは ReadText メソッドを使って、Stream からバイトを読み取ります。
　 Flush メソッドを使って、ADO バッファにある Stream データを基になるオブジェクトに書き込みます。
　 CopyTo メソッドを使って、Stream の内容を別の Stream にコピーします。
　 SkipLine メソッドおよび LineSeparator プロパティを使って、ソース ファイルから行を読み取る方法を制御します。
　 EOS プロパティおよび SetEOS メソッドを使って、ストリーム位置の末尾を設定します。
　 SaveToFile メソッドおよび LoadFromFile メソッドを使って、ファイル内のデータを保存および復元します。
　 Charset プロパティを使って、Stream の保存に使う文字セットを指定します。
　 Cancel メソッドを使って、非同期 Stream 操作を停止します。
　 Size プロパティを使って、Stream 内のバイト数を設定します。
　 Position プロパティを使って、Stream 内の現在の位置を制御します。
　 Type プロパティを使って、Stream 内のデータ型を設定します。
　 State プロパティを使って、Stream の現在の状態 (開いている、閉じている、または実行中) を設定します。
　 Mode プロパティを使って、Stream のアクセス モードを指定します。

ADOでCSVの読み込み（SQL）

ADOでCSVの読み込み（SQL）
　VBAでADOを使用し、CSVデータを読み込みます。ADOではSQL文が必要になりますが、ここではSQL文の詳細については説明を省略します。ADO以外の方法については、「CSVの読み込み方法」を参考にして下さい。
　VBAでADOを使用し、CSVデータを読み込みます。
　ADOではSQL文が必要になりますが、
　ここではSQL文の詳細については説明を省略します。
　エクセルのブックと同一フォルダにある「TESTCSV.csv」を読み込み、
　シート「CSV」に貼り付けています。

CSVの読み込み方法（ジャグ配列）（改）

　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。
　順次改定していくつかのバージョンが存在します。
　最新のジャグ配列（配列の配列）で読み込むVBAについて、UTF-8Nの文字コード判別の課題が残っていました。
　文字コードの判定を全て完璧に行うのは無理ですが、簡易的にでもUTF-8Nを判定したいところです。
　そこで、いろいろなサイトを参考にして、これに対応するVBAを作成しました。
　また、使うにあたって参照設定が面倒な場合もあるので、参照設定せずにCreateObjectに変更してコピペで使いやすくしています。
　現在、本サイト内のCSV関連としては以下のページがあります。
　 VBAでのCSVの扱い方まとめ
　マクロVBAでCSVの読み書きする方法はいくつもあり、当サイトでも複数のページでそれぞれVBAコードを掲載しています。順次記事を掲載し ているので、それぞれどのような特徴があるかが良く分からなくなってしまっているようです。そこで、CSVに関するページをまとめておきました。
　 CSVの読み込み方法
　エクセルのVBAでのCSVの読込方法としては。・テキストファイルとして読み込む ・ワークブックとして読み込む ・クエリーテーブルを使う ・ADOを使う ・PowerQueryを使う 大別するとこのようになります。この記事を書いた当初は、エクセルのVBAでCSVの読み込みについてネットで検索したところ、
　 CSVの読み込み方法（改）
　実施したいこと ・ファイル名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラ ムで区切らない。掲示板で上記のリクエストを頂きました。ということで、対応ロジックを書いてみました。
　 CSVの読み込み方法（改の改）
　CSVのVBAでの読込方法については複数の記事を掲載しており、人気記事として多くのアクセスがあります。掲載しているVBAコードは汎用的 に書いてあり、ほぼそのまま使用できるものです。しかし、CSVは多くの形式（区切り文字、文字コード等）があり、今まで掲載したコードでは解決出来ない ものがあります。
　 CSVの読み込み方法（ジャグ配列）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。当初作成して以来、ご要望をいただいたり自身で 使っている中で、対応できないCSVが出てくるたびに改良を重ねています。今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。
　 CSVの出力（書き出し）方法
　シート内容をCSV出力（書き出し）する方法です。CSVの読込は、「CSVの読込方法」「CSVの読込方法（改）」実施したいこと・ファイル 名を指定し、形式をカンマ区切り、文字列で開く、その際、改行コードLF、CRLF、CRいずれにも対応、セル内の","や改行についてはカラムで区切ら ない。
　 UTF-8でCSVの読み書き（ADODB.Stream）
　VBAでUTF-8を扱う為には、ADODB.Streamを使う必要があります。以下のコードを使用するには、参照設定で、 「MicrosoftActiveXDataObjects2.8Library」にチェックを付けて下さい。または、 DimadoStAsNewADODB.Stream ここを DimadoStAsObject SetadoSt=CreateO…

CSV読み込みVBAコード：CSVの読み込み方法（ジャグ配列）（改）


　
'CSVファイルを指定シートに出力
　Public Sub CsvToSheet(ByVal ws As Worksheet, _
　　　　　　　　　　　　ByVal strFile As String, _
　　　　　　　　　　　　Optional ByVal CharSet As String = "Auto")
　　　Dim myArray() As Variant
　 'readCsvでCSVを読み込み
　　　Dim strRec As String
　　　strRec = readCsv(strFile, CharSet)
　 'CsvToJaggedで行・フィールドに分割してジャグ配列に
　　　Dim jagArray() As Variant
　　　jagArray = CsvToJagged(strRec)
　 'JaggedTo2Dでジャグ配列を2次元配列に変換
　　　Call JaggedTo2D(jagArray, myArray)
　 '上記を全てネストすれば以下で書けますが、お勧めはしません。
　 'Call JaggedTo2D(CsvToJagged(readCsv(strFile, CharSet)), myArray)
　 '2次元配列→シート
　　　ws.Range("A1").Resize(UBound(myArray, 1), UBound(myArray, 2)) = myArray
　End Sub
　 'ジャグ配列を2次元配列に変換
　Private Sub JaggedTo2D(ByRef jagArray() As Variant, _
　　　　　　　　　　　　 ByRef twoDArray As Variant)
　 'ジャグ配列の最大列数取得
　　　Dim maxCol As Long, v As Variant
　　　maxCol = 0
　　　For Each v In jagArray
　　　　　If UBound(v) > maxCol Then
　　　　　　　maxCol = UBound(v)
　　　　　End If
　　　Next
　 'ジャグ配列→2次元配列
　　　Dim i1 As Long, i2 As Long
　　　ReDim twoDArray(1 To UBound(jagArray), 1 To maxCol)
　　　For i1 = 1 To UBound(jagArray)
　　　　　For i2 = 1 To UBound(jagArray(i1))
　　　　　　　twoDArray(i1, i2) = jagArray(i1)(i2)
　　　　　Next
　　　Next
　End Sub
　Private Function CsvToJagged(ByVal strRec As String) As Variant()
　　　Dim childArray() As Variant 'ジャグ配列の子配列
　　　Dim lngQuate As Long 'ダブルクォーテーション数
　　　Dim strCell As String '1フィールド文字列
　　　Dim blnCrLf As Boolean '改行判定
　　　Dim i As Long '行位置
　　　Dim j As Long '列位置
　　　Dim k As Long
　　　ReDim CsvToJagged(1 To 1) 'ジャグ配列の初期化
　　　ReDim childArray(1 To 1) 'ジャグ配列の子配列の初期化
　　　i = 1 'シートの1行目から出力
　　　j = 0 '列位置はputChildArrayでカウントアップ
　　　lngQuate = 0 'ダブルクォーテーションの数
　　　strCell = ""
　　　For k = 1 To Len(strRec)
　　　　　Select Case Mid(strRec, k, 1)
　　　　　　　Case vbLf, vbCr '「"」が偶数なら改行、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　blnCrLf = False
　　　　　　　　　　　If k > 1 Then '改行のCrLfはCrで改行判定済なので無視する
　　　　　　　　　　　　　If Mid(strRec, k - 1, 2) = vbCrLf Then
　　　　　　　　　　　　　　　blnCrLf = True
　　　　　　　　　　　　　End If
　　　　　　　　　　　End If
　　　　　　　　　　　If blnCrLf = False Then
　　　　　　　　　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　 'これが改行となる
　　　　　　　　　　　　　Call putjagArray(CsvToJagged, childArray, _
　　　　　　　　　　　　　　　　　　　　　 i, j, lngQuate, strCell)
　　　　　　　　　　　End If
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case ",", vbTab '「"」が偶数なら区切り、奇数ならただの文字
　　　　　　　　　If lngQuate Mod 2 = 0 Then
　　　　　　　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　　　　　　　　　Else
　　　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　　　End If
　　　　　　　Case """" '「"」のカウントをとる
　　　　　　　　　lngQuate = lngQuate + 1
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　　　Case Else
　　　　　　　　　strCell = strCell & Mid(strRec, k, 1)
　　　　　End Select
　　　Next
　 '最終行の最終列の処理
　　　If j > 0 And strCell <> "" Then
　　　　　Call putChildArray(childArray, j, strCell, lngQuate)
　　　　　Call putjagArray(CsvToJagged, childArray, _
　　　　　　　　　　　　　 i, j, lngQuate, strCell)
　　　End If
　End Function
　Private Sub putjagArray(ByRef jagArray() As Variant, _
　　　　　　　　　　　　　ByRef childArray() As Variant, _
　　　　　　　　　　　　　ByRef i As Long, _
　　　　　　　　　　　　　ByRef j As Long, _
　　　　　　　　　　　　　ByRef lngQuate As Long, _
　　　　　　　　　　　　　ByRef strCell As String)
　　　If i > UBound(jagArray) Then '常に成立するが一応記述
　　　　　ReDim Preserve jagArray(1 To i)
　　　End If
　　　jagArray(i) = childArray '子配列をジャグ配列に入れる
　　　ReDim childArray(1 To 1) '子配列の初期化
　　　i = i + 1 '列位置
　　　j = 0 '列位置
　　　lngQuate = 0 'ダブルクォーテーション数
　　　strCell = "" '1フィールド文字列
　End Sub
　 '1フィールドごとにセルに出力
　Private Sub putChildArray(ByRef childArray() As Variant, _
　　　　　　　　　　　　　　ByRef j As Long, _
　　　　　　　　　　　　　　ByRef strCell As String, _
　　　　　　　　　　　　　　ByRef lngQuate As Long)
　　　j = j + 1
　 '「""」を「"」で置換
　　　strCell = Replace(strCell, """""", """")
　 '前後の「"」を削除
　　　If Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
　　　　　If Len(strCell) <= 2 Then
　　　　　　　strCell = ""
　　　　　Else
　　　　　　　strCell = Mid(strCell, 2, Len(strCell) - 2)
　　　　　End If
　　　End If
　　　If j > UBound(childArray) Then
　　　　　ReDim Preserve childArray(1 To j)
　　　End If
　　　childArray(j) = strCell
　　　strCell = ""
　　　lngQuate = 0
　End Sub
　 '文字コードを自動判別し、全行をCrLf区切りに統一してStringに入れる
　Private Function readCsv(ByVal strFile As String, _
　　　　　　　　　　　　　 ByVal CharSet As String) As String
　 '　　Dim objFSO As New FileSystemObject
　 '　　Dim inTS As TextStream
　 '　　Dim adoSt As New ADODB.Stream
　　　Dim objFSO As Object
　　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　　Dim inTS As Object
　　　Dim adoSt As Object
　　　Set adoSt = CreateObject("ADODB.Stream")
　　　Dim strRec As String
　　　Dim i As Long
　　　Dim aryRec() As String
　　　If CharSet = "Auto" Then CharSet = getCharSet(strFile)
　　　Select Case UCase(CharSet)
　　　　　Case "UTF-8", "UTF-8N"
　 'ADOを使って読込、その後の処理を統一するため全レコードをCrLfで結合
　 'Set inTS = objFSO.OpenTextFile(strFile, ForAppending)
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile, 8)
　　　　　　　i = inTS.Line - 1
　　　　　　　inTS.Close
　　　　　　　ReDim aryRec(i)
　　　　　　　With adoSt
　 '.Type = adTypeText
　　　　　　　　　.Type = 2
　　　　　　　　　.CharSet = "UTF-8"
　　　　　　　　　.Open
　　　　　　　　　.LoadFromFile strFile
　　　　　　　　　i = 0
　　　　　　　　　Do While Not (.EOS)
　 'aryRec(i) = .ReadText(adReadLine)
　　　　　　　　　　　aryRec(i) = .ReadText(-2)
　　　　　　　　　　　i = i + 1
　　　　　　　　　Loop
　　　　　　　　　.Close
　　　　　　　　　strRec = Join(aryRec, vbCrLf)
　　　　　　　End With
　　　　　Case "UTF-16 LE", "UTF-16 BE"
　 'Set inTS = objFSO.OpenTextFile(strFile, , , TristateTrue)
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile, , , -1)
　　　　　　　strRec = inTS.ReadAll
　　　　　　　inTS.Close
　　　　　Case "SHIFT_JIS"
　　　　　　　Set inTS = objFSO.OpenTextFile(strFile)
　　　　　　　strRec = inTS.ReadAll
　　　　　　　inTS.Close
　　　　　Case Else
　 'EUC-JP、UTF-32については未テスト
　　　　　　　MsgBox "文字コードを確認してください。" & vbLf & CharSet
　　　　　　　Stop
　　　End Select
　　　Set inTS = Nothing
　　　Set objFSO = Nothing
　　　readCsv = strRec
　End Function
　 '文字コードの自動判別
　Private Function getCharSet(strFileName As String) As String
　　　Dim bytes() As Byte
　　　Dim intFileNo As Integer
　　　ReDim bytes(FileLen(strFileName))
　　　intFileNo = FreeFile
　　　Open strFileName For Binary As #intFileNo
　　　Get #intFileNo, , bytes
　　　Close intFileNo
　 'BOMによる判断
　　　getCharSet = getCharFromBOM(bytes)
　 'BOMなしをデータの文字コードで判別
　　　If getCharSet = "" Then
　　　　　getCharSet = getCharFromCode(bytes)
　　　End If
　　　Debug.Print strFileName & " : " & getCharSet
　End Function
　 'BOMによる判断
　Private Function getCharFromBOM(ByRef bytes() As Byte) As String
　　　getCharFromBOM = ""
　　　If UBound(bytes) < 3 Then Exit Function
　　　Select Case True
　　　　　Case bytes(0) = &HEF And _
　　　　　　　 bytes(1) = &HBB And _
　　　　　　　 bytes(2) = &HBF
　　　　　　　getCharFromBOM = "UTF-8"
　　　　　　　Exit Function
　　　　　Case bytes(0) = &HFF And _
　　　　　　　 bytes(1) = &HFE
　　　　　　　 If bytes(2) = &H0 And _
　　　　　　　　　bytes(3) = &H0 Then
　　　　　　　　　getCharFromBOM = "UTF-32 LE"
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　　　getCharFromBOM = "UTF-16 LE"
　　　　　　　Exit Function
　　　　　Case bytes(0) = &HFE And _
　　　　　　　 bytes(1) = &HFF
　　　　　　　getCharFromBOM = "UTF-16 BE"
　　　　　　　Exit Function
　　　　　Case bytes(0) = &H0 And _
　　　　　　　 bytes(1) = &H0 And _
　　　　　　　 bytes(2) = &HFE And _
　　　　　　　 bytes(3) = &HFF
　　　　　　　getCharFromBOM = "UTF-32 BE"
　　　　　　　Exit Function
　　　End Select
　End Function
　 '以下は下記サイトのコードをVBAに移植
　 'https://dobon.net/vb/dotnet/string/detectcode.html
　 'BOMなしをデータの文字コードで判別
　Private Function getCharFromCode(ByRef bytes() As Byte) As String
　　　Const bEscape As Byte = &H1B
　　　Const bAt As Byte = &H40
　　　Const bDollar As Byte = &H24
　　　Const bAnd As Byte = &H26
　　　Const bOpen As Byte = &H28
　　　Const bB As Byte = &H42
　　　Const bD As Byte = &H44
　　　Const bJ As Byte = &H4A
　　　Const bI As Byte = &H49
　　　Dim bLen As Long: bLen = UBound(bytes)
　　　Dim b1 As Byte, b2 As Byte, b3 As Byte, b4 As Byte
　　　Dim isBinary As Boolean: isBinary = False
　　　Dim i As Integer
　　　For i = 0 To bLen - 1
　　　　　b1 = bytes(i)
　　　　　If b1 <= &H6 Or b1 = &H7F Or b1 = &HFF Then
　　　　　　　isBinary = True
　　　　　　　If b1 = &H0 And i < bLen - 1 And bytes(i + 1) <= &H7F Then
　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　End If
　　　Next
　　　If isBinary Then
　　　　　getCharFromCode = ""
　　　　　Exit Function
　　　End If
　　　For i = 0 To bLen - 3
　　　　　b1 = bytes(i)
　　　　　b2 = bytes(i + 1)
　　　　　b3 = bytes(i + 2)
　　　　　If b1 = bEscape Then
　　　　　　　If b2 = bDollar And b3 = bAt Then
　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　Exit Function
　　　　　　　ElseIf b2 = bDollar And b3 = bB Then
　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　Exit Function
　　　　　　　ElseIf b2 = bOpen And (b3 = bB Or b3 = bJ) Then
　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　Exit Function
　　　　　　　ElseIf b2 = bOpen And b3 = bI Then
　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　Exit Function
　　　　　　　End If
　　　　　　　If i < bLen - 3 Then
　　　　　　　　　b4 = bytes(i + 3)
　　　　　　　　　If b2 = bDollar And b3 = bOpen And b4 = bD Then
　　　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　　　Exit Function
　　　　　　　　　End If
　　　　　　　　　If i < bLen - 5 And _
　　　　　　　　　　　b2 = bAnd And b3 = bAt And b4 = bEscape And _
　　　　　　　　　　　bytes(i + 4) = bDollar And bytes(i + 5) = bB Then
　　　　　　　　　　　getCharFromCode = "Shift_JIS"
　　　　　　　　　　　Exit Function
　　　　　　　　　End If
　　　　　　　End If
　　　　　End If
　　　Next
　　　Dim sjis As Integer: sjis = 0
　　　Dim euc As Integer: euc = 0
　　　Dim utf8 As Integer: utf8 = 0
　　　For i = 0 To bLen - 2
　　　　　b1 = bytes(i)
　　　　　b2 = bytes(i + 1)
　　　　　If ((&H81 <= b1 And b1 <= &H9F) Or (&HE0 <= b1 And b1 <= &HFC)) And _
　　　　　　 ((&H40 <= b2 And b2 <= &H7E) Or (&H80 <= b2 And b2 <= &HFC)) Then
　　　　　　　sjis = sjis + 2
　　　　　　　i = i + 1
　　　　　End If
　　　Next
　　　For i = 0 To bLen - 2
　　　　　b1 = bytes(i)
　　　　　b2 = bytes(i + 1)
　　　　　If ((&HA1 <= b1 And b1 <= &HFE) And _
　　　　　　　(&HA1 <= b2 And b2 <= &HFE)) Or _
　　　　　　　(b1 = &H8E And (&HA1 <= b2 And b2 <= &HDF)) Then
　　　　　　　euc = euc + 2
　　　　　　　i = i + 1
　　　　　ElseIf i < bLen - 2 Then
　　　　　　　b3 = bytes(i + 2)
　　　　　　　If b1 = &H8F And (&HA1 <= b2 And b2 <= &HFE) And _
　　　　　　　　　(&HA1 <= b3 And b3 <= &HFE) Then
　　　　　　　　　euc = euc + 3
　　　　　　　　　i = i + 2
　　　　　　　End If
　　　　　End If
　　　Next
　　　For i = 0 To bLen - 2
　　　　　b1 = bytes(i)
　　　　　b2 = bytes(i + 1)
　　　　　If (&HC0 <= b1 And b1 <= &HDF) And _
　　　　　　　(&H80 <= b2 And b2 <= &HBF) Then
　　　　　　　utf8 = utf8 + 2
　　　　　　　i = i + 1
　　　　　ElseIf i < bLen - 2 Then
　　　　　　　b3 = bytes(i + 2)
　　　　　　　If (&HE0 <= b1 And b1 <= &HEF) And _
　　　　　　　　　(&H80 <= b2 And b2 <= &HBF) And _
　　　　　　　　　(&H80 <= b3 And b3 <= &HBF) Then
　　　　　　　　　utf8 = utf8 + 3
　　　　　　　　　i = i + 2
　　　　　　　End If
　　　　　End If
　　　Next
　　　Select Case True
　　　　　Case euc > sjis And euc > utf8
　　　　　　　getCharFromCode = "EUC-JP"
　　　　　Case utf8 > euc And utf8 > sjis
　　　　　　　getCharFromCode = "UTF-8N"
　　　　　Case sjis > euc And sjis > utf8
　　　　　　　getCharFromCode = "SHIFT-JIS"
　　　　　Case Else '判定できず
　　　　　　　getCharFromCode = ""
　　　End Select
　End Function
前作の、
　 CSVの読み込み方法（ジャグ配列）
　CSVのマクロVBAでの読込方法についての記事は、人気記事として多くのアクセスがあります。当初作成して以来、ご要望をいただいたり自身で 使っている中で、対応できないCSVが出てくるたびに改良を重ねています。今回のVBAは、一旦ジャグ配列を使用したCSV読み込み方法になります。
　これとの違いは、
　文字コード自動判別の getCharSet と、参照設定を CreateObject に変更しているだけになります。
　参照設定を外しているので、各種定数（ForAppending、TristateTrue）も直接数値に変更しています。
　文字コードの判定は、これで完璧ということではありません。
　※文字コード自動判定の作成にあたって
　以下のサイトに掲載されているコードをもとに若干の修正を加えつつ VBAに移植 したものになります。
　文字コードを判別する - .NET Tips (VB.NET,C#...)
　https://dobon.net/vb/dotnet/string/detectcode.html
　Windows10のメモ帳もデフォルトがUTF-8になりました。
　 これらの文字コードについてのみ対応したものになります。
　 EUC-JP 、 UTF-32 LE 、 UTF-32 BE については、確認テストが困難なため、
　 文字コード判定のみ実装 し、実際の CSV読込については未実装 です。

CSVの読み込み方法（ジャグ配列）（改）の使用例


　
Sub sample()
　　　Dim ws As Worksheet
　　　Dim vFile As Variant
　　　vFile = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
　　　　　　　　　　　　　　　　　　　　　Title:="CSVファイルの選択")
　　　If vFile = False Then Exit Sub
　 '出力シート
　　　Set ws = ActiveSheet
　　　ws.Cells.Clear
　 '全列を文字に設定、数値も文字としてセルに入ります
　 '文字設定にしなければ数値は数値として入ります。
　　　ws.Cells.NumberFormatLocal = "@"
　 'CSV取込、文字コード自動判別
　　　Application.ScreenUpdating = False
　　　Call CsvToSheet(ws, vFile)
　　　Application.ScreenUpdating = True
　End Sub
CSVの読み込み方法（ジャグ配列）の使用例です。
　上記では、全列を文字設定にしていますが、数値はセルに数値（先頭0が消える）として出力する場合は、
　当該列の表示形式を「G/標準」または数値の書式設定（#,##0等）にしてください。

セル結合/解除でセル値を退避/回復

　セル結合の弊害はネットに溢れているのでここで改めて説明の必要はないでしょう。
　とはいえ、セル結合したい場合もありますよね、人間だからね。
　VBAで適切に処理すればセル結合もきちんと処理は可能です。
　 第85回.結合セルの扱い｜VBA入門
　セルが結合されていると、マクロでは時に扱いづらい事があります、セル結合されている場合に、VBAでどのように取り扱うかを解説します。そもそも、やたらにセル結合すべきではないのですが、見た目重視で作られたシートでは、セル結合が頻繁に使用されているものです。
　しかし、セル結合した時にどうしようもないのが、各セル値が失われてしまうことです。
　セル結合すると、先頭セルの値だけが残り他のセル値は消えてしまいます。
　これは、どうしようもありません。
　そこで、セル結合した時にセル値をどこかに退避しておき、セル結合を解除した時に復元するVBAを考えてみました。
　とはいえ、実際にこのVBAが必要になる事はほとんどないでしょう。
　VBAを扱う人なら、セル結合があると面倒なことは承知しているはずですので、VBAで結合するという事自体が少ないでしょう。
　さらに結合で失われる値を保持する必要がある場合などなかなか想定できません。
　また、決してセル結合を推奨しているわけではないという事だけは申し上げておきます。
　あくまで、セル結合等で失われてしまう情報の退避/回復方法のひとつとしてのサンプルVBAを提示してみたもになります。
　従って、どちらかと言うとCustomDocumentPropertiesの使い方のサンプルになります。

セル結合/解除でセル値を退避/回復のVBA


　
'指定セル範囲をセル結合
　Sub MergeRange(ByVal aRange As Range)
　　　If IsNull(aRange.MergeCells) Or aRange.MergeCells Then
　　　　　If MsgBox("結合セルが含まれています。" & vbLf & _
　　　　　　　　　　"続行しますか?" & vbLf & vbLf & _
　　　　　　　　　　"続行し場合、結合されているセルの値は失われます。", _
　　　　　　　　　　vbYesNo + vbDefaultButton2, "確認") = vbNo Then
　　　　　　　Exit Sub
　　　　　End If
　　　End If
　　　Call StoreRange(aRange)
　　　Dim isDisplayAlerts As Boolean
　　　isDisplayAlerts = Application.DisplayAlerts
　　　Application.DisplayAlerts = False
　　　aRange.Merge
　　　Application.DisplayAlerts = isDisplayAlerts
　End Sub
　 '指定セル範囲の先頭セルの結合範囲を解除
　Sub UnMergeRange(ByVal aRange As Range)
　　　Set aRange = aRange.Item(1).MergeArea '先頭セル
　　　aRange.UnMerge
　　　Call RestoreRange(aRange)
　　　Dim wb As Workbook
　　　Set wb = aRange.Worksheet.Parent
　　　Dim myRange As Range
　　　For Each myRange In aRange
　　　　　Call DelCustomDocumentProperties(wb, myRange)
　　　Next
　End Sub
　 '指定セル範囲をCustomDocumentPropertiesに退避
　Sub StoreRange(ByVal aRange As Range)
　　　Dim myRange As Range
　　　For Each myRange In aRange
　　　　　Call AddCustomDocumentProperties(myRange)
　　　Next
　End Sub
　 '指定セル範囲のValueとNumberFormatLocalをCustomDocumentPropertiesから復元
　Sub RestoreRange(ByVal aRange As Range)
　　　Dim wb As Workbook
　　　Set wb = aRange.Worksheet.Parent
　　　Dim myRange As Range
　　　Dim sAddress As String
　　　For Each myRange In aRange
　　　　　If myRange.Address <> aRange.Item(1).Address Then '先頭セルは変更しない
　　　　　　　sAddress = aRange.Worksheet.Name & "!" & myRange.Address(False, False)
　　　　　　　myRange.Value = getCustomDocumentProperties(wb, sAddress & "_Value")
　　　　　　　myRange.NumberFormatLocal = _
　　　　　　　　　getCustomDocumentProperties(wb, sAddress & "_NumberFormatLocal")
　　　　　End If
　　　Next
　End Sub
　 '指定文字列のCustomDocumentPropertiesを取得
　Function getCustomDocumentProperties(ByVal wb As Workbook, _
　　　　　　　　　　　　　　　　　　　 ByVal aProperties As String) As String
　　　On Error Resume Next
　　　getCustomDocumentProperties = wb.CustomDocumentProperties(aProperties)
　End Function
　 '指定セルのValueとNumberFormatLocalをCustomDocumentPropertiesへ退避
　Sub AddCustomDocumentProperties(ByVal aRange As Range)
　　　Dim wb As Workbook
　　　Set wb = aRange.Worksheet.Parent
　　　Dim dps As DocumentProperties
　　　Dim sAddress As String
　　　Set dps = wb.CustomDocumentProperties
　　　sAddress = aRange.Worksheet.Name & "!" & aRange.Address(False, False)
　 'CustomDocumentPropertiesから削除
　　　Call DelCustomDocumentProperties(wb, sAddress)
　 'CustomDocumentPropertiesへ追加
　　　dps.Add sAddress & "_Value", False, msoPropertyTypeString, aRange.Value
　　　dps.Add sAddress & "_NumberFormatLocal", False, msoPropertyTypeString, aRange.NumberFormatLocal
　End Sub
　 '指定セルのCustomDocumentPropertiesを削除
　Sub DelCustomDocumentProperties(ByVal wb As Workbook, _
　　　　　　　　　　　　　　　　　ByVal aAddress As String)
　　　Dim dps As DocumentProperties
　　　Set dps = wb.CustomDocumentProperties
　　　Dim dp As DocumentProperty
　　　For Each dp In dps
　　　　　If dp.Name Like aAddress & "_*" Then
　　　　　　　dp.Delete
　　　　　End If
　　　Next
　End Sub
CustomDocumentPropertiesについては、以下を参照してください。
　 ドキュメントプロパティ（BuiltinDocumentProperties,CustomDocumentProperties）
　VBAで配列を必要とするのは、処理速度を上げる為だと言えます、そもそも、エクセルにはセルの2次元配列であるシートがあります。にもかかわ らず、VBAの学習を進めると必ず配列が出てきます、ではなぜVBAで配列必須になるかと言うと、セルを使うと処理速度が非常に遅く、これを高速に処理す るために配列が必要となるからです。
　上のVBAでは、ValueとNumberFormatLocalだけを扱っています。
　罫線はプロパティが多くなるので大変ですが、必要なら適宜追加してください。
　さすがに、条件付き書式や入力規則まで含めるとかなり難しくなってきます。
　もっとも、結合解除した時に条件付き書式や入力規則をどうするかは色々と考えないといけない問題です。
　また、結合解除した時に、先頭セルと同じ状態にしたい場合もあると思います。
　そのような場合は、「RestoreRange」にオプション引数を追加するなりして、
　aRange.Item(1)の情報を使うようにすれば良いでしょう。

セル結合/解除でセル値を退避/回復のVBAの使い方


　
Sub セル結合する()
　　　Call MergeRange(Range("D2:D4"))
　End Sub
　Sub セル結合を解除()
　　　Call UnMergeRange(Range("D2"))
　End Sub
使い方は簡単なので問題はないでしょう。
　登録されたCustomDocumentPropertiesの全削除や一覧は、この下に掲載しています。

退避したセル値の全削除と一覧出力

上のVBAでCustomDocumentPropertiesに退避した情報を全クリアしたい場合や、
　CustomDocumentPropertiesの一覧を取得したい場合に使ってください。
　
Sub 使い方サンプル()
　　　Call CustomDocumentProperties2Sheet(ActiveWorkbook, ActiveSheet)
　　　Call AllDelCustomDocumentProperties(ActiveWorkbook)
　End Sub
　 'CustomDocumentPropertiesを全削除
　Sub AllDelCustomDocumentProperties(ByVal wb As Workbook)
　　　Dim dp As DocumentProperty
　　　For Each dp In wb.CustomDocumentProperties
　　　　　dp.Delete
　　　Next
　End Sub
　 'CustomDocumentPropertiesの一覧をシート出力
　Sub CustomDocumentProperties2Sheet(ByVal wb As Workbook, _
　　　　　　　　　　　　　　　　　　 ByVal ws As Worksheet)
　　　Dim dps As DocumentProperties
　　　Dim dp As DocumentProperty
　　　Dim i As Long
　 'Valueが定義エラーの場合の対応
　　　On Error Resume Next
　　　With ws
　　　　　.Cells.Clear
　　　　　.Range("A1") = "インデックス"
　　　　　.Range("B1") = "プロパティ名"
　　　　　.Range("C1") = "型"
　　　　　.Range("D1") = "値"
　　　　　i = 1
　　　　　Set dps = wb.CustomDocumentProperties
　　　　　For Each dp In dps
　　　　　　　.Cells(i + 1, 1) = i
　　　　　　　.Cells(i + 1, 2).Value = dp.Name
　　　　　　　.Cells(i + 1, 3).Value = dp.Type
　　　　　　　.Cells(i + 1, 4).Value = dp.Value
　　　　　　　i = i + 1
　　　　　Next
　　　End With
　End Sub
　
一覧のシート出力では、シート全体をクリアしているので注意下ください。

セル結合/解除の最後に

セル結合は、確かに弊害が多くできれば使わない方が良いでしょう。
　とはいえ、VBAを書く人の多くが他人の要望を受けて作成している場合は多いでしょう。
　そんな時、どうしても断れずにセル結合せざる負えなくなってしまったときに、こんな方法もあるのだという事を思い出してもらえれば良いと思います。
　ただし、セル結合せずに済むならそれが一番良い事は言うまでもありませんので、セル結合しないように良く話をしてみましょう。

セル結合なんて絶対に許さないんだからね

　セル結合の弊害はネットに溢れているのでここで改めて説明の必要はないでしょう。
　とはいえ、ついついセル結合してしまう事ありますよね、人間だからね。
　VBAで適切に処理すればセル結合もきちんと処理は可能です。
　 第85回.結合セルの扱い｜VBA入門
　セルが結合されていると、マクロでは時に扱いづらい事があります、セル結合されている場合に、VBAでどのように取り扱うかを解説します。そもそも、やたらにセル結合すべきではないのですが、見た目重視で作られたシートでは、セル結合が頻繁に使用されているものです。
　しかし、セル結合しちゃダメと言われたらやらないほうが良いですね。
　でも、ダメと言われるとやりたくなっちゃうのが男の子・・・その気持ちはわかります・・・
　でもダメー、絶対にセル結合を許さないVBAがここにあります。
　このVBAを起動したら、結合すると間髪入れずにセル結合解除していきます。
　これでもう、セル結合は絶対にできない。※ほほ冗談アプリです。
　実際に使う場合は全て自己責任でお願いします。

セル結合なんて絶対に許さないVBA


　
Option Explicit
　Public Declare PtrSafe Function SetTimer Lib "USER32" _
　　　　　　　　　　　　　　　　　　　　　(ByVal hwnd As Long, _
　　　　　　　　　　　　　　　　　　　　　ByVal nIDEvent As Long, _
　　　　　　　　　　　　　　　　　　　　　ByVal uElapse As Long, _
　　　　　　　　　　　　　　　　　　　　　ByVal lpTimerFunc As LongPtr) As Long
　Public Declare PtrSafe Function KillTimer Lib "USER32" _
　　　　　　　　　　　　　　　　　　　　　(ByVal hwnd As Long, _
　　　　　　　　　　　　　　　　　　　　　ByVal nIDEvent As Long) As Long
　Public mTimerID As Long
　Sub TimerStart ()
　　　If mTimerID <> 0 Then
　　　　　MsgBox "起動済です。"
　　　　　Exit Sub
　　　End If
　　　mTimerID = SetTimer(0&, 1&, 100&, AddressOf TimerProc)
　End Sub
　Sub TimerProc()
　　　If mTimerID = 0 Then End '終了できない時の対策
　　　On Error Resume Next 'デバッグ出すとExcelが固まるので
　　　If IsNull(Cells.MergeCells) Then
　　　　　Cells.MergeCells = False
　　　End If
　End Sub
　Sub TimerSto p()
　　　Call KillTimer(0&, mTimerID)
　　　mTimerID = 0
　End Sub
TimerStart を起動してください。
　アクティブシートを監視して、セル結合があると直ぐに解除します。
　間隔は100msにしていますので、ほぼ瞬時に解除されてしまいます。
　対象シートは常にアクティブシートです。
　どのブック、どのシートとかは何も判定していません。
　シートを切り替えても、その時々のアクティブシートが対象です。
　とにかく無条件でアクティブシートのセル結合を解除します。
　このマクロ実行中もセルへの入力は普通にできますし、他のマクロを実行することもできます。
　しかし、たとえ他のマクロでセル結合したとしても、このマクロで直ちに解除されてしまいます。
　マクロでアクティブシート以外のシートをセル結合した場合は解除されません。
　また、100msの間隔があるので、その間にアクティブシートを切り替えればやはり解除されません。

停止方法

必ず、 TimerStop を起動してください。
　これで停止させずにExcelを閉じた場合、非表示状態のExcelがタスクに残る場合があります。
　新たにエクセルを起動できなくなった等の現象になった場合は、タスクマネージャーを確認してください。

ＳｅｔＴｉｍｅｒについて

VBAでのタイマー処理（SetTimer,OnTime）
　VBAでタイマー処理（一定時間間隔で処理）を行う方法についての解説です。最も一般的な方法は、Application.OnTimeを使う 方法になりますが、今回の主題としては、WindowsAPIのSetTimerを紹介します。まずはApplication.OnTimeの確認してか ら、次にWindowsAPIのSetTimerを紹介します。
　 ※※※ 注意 ※※※
　APIのタイマー処理をしていますので、使い方を誤るとエクセルが固まったり消えてなくなったりします。

セル結合なんて絶対に許さないの最後に

先にも書きましたが、VBA自体はほぼ冗談アプリです。
　あくまで、自分やってみて、こんなこともできるんだという程度のものとお考え下さい。
　実務で使おうなどとは思わないほうがよろしいかと思います。
　そもそもセル結合が全て悪ということではありません。
　WEBで良く見かけるセル結合を批判しているもののほとんどは、
　セル結合が適切に使われておらず、エクセルの作業の邪魔をしていたり、データ活用を阻害している場合に対してのものです。
　セル結合も適切に使えばエクセルの便利な機能の一つなのです。

セルの数式をネスト色分けしてコメント表示

　数式のネストが3段階を超えてくる、なかなか読むのが辛くなってきます。
　数式を改行したりして見やすくするにも限界があります。
　特別に複雑な数式を解析する場合は、以下を試してみてください。
　 Excelシートの複雑な計算式を解析するVBA
　セルに入力されている数式が折り返されていて複数行（ときに3行以上）になっている場合、数式バーで見ていたのでは、どんな数式なのかがさっぱ りわからなくなります。このような複雑な数式を分解し、分かり易く表示するVBAを作成しました。最初に言っておきますが、そもそも、そのような複雑な数 式は作らないほうが良いというのが基本です。
　このようなツールを使うほどではないが、数式を色分けしてちょっと見やすくなれば、そんな場合を想定しています。
　ここで言うコメントは、最新のOffice365にでは「メモ」と呼ばれるものです。
　Office365では従来の「コメント」が「メモ」になった訳ですが、ページタイトルでは馴染みのある「コメント」を使っています。
　完成イメージは、このようになります。
　 ※下の数式が改行されているのは、元々の数式が改行されている為です。

セルの数式をネスト色分けしてコメント表示のVBA


　
'ネスト色分けした数式コメント作成
　Public Sub setNestColorComment(ByVal argRange As Range)
　　　Dim objComment As Comment
　　　Set objComment = addFormulaComment(argRange)
　　　Call setFontColor(objComment)
　　　objComment.Visible = True
　End Sub
　 '数式コメント作成
　Private Function addFormulaComment(ByVal argRange As Range) As Comment
　　　Dim objComment As Comment
　　　If Not argRange.Comment Is Nothing Then
　　　　　argRange.Comment.Delete
　　　End If
　　　Set objComment = argRange.AddComment
　　　With objComment
　　　　　.Text Text:=argRange.Formula
　　　　　.Shape.TextFrame.Characters.Font.Size = 14
　　　　　.Shape.TextFrame.Characters.Font.Bold = True
　　　　　.Shape.Top = argRange.Top + 8
　　　　　.Shape.Left = argRange.Offset(, 1).Left + 8
　　　　　.Shape.TextFrame.AutoSize = True
　　　End With
　　　Set addFormulaComment = objComment
　End Function
　 '数式ネストに段階的に色を設定
　Private Sub setFontColor(ByVal obj As Comment)
　　　Dim i As Long, ix As Long, lv As Long
　　　Dim dQuot As Boolean, sQuot As Boolean
　　　lv = 0
　　　For i = 1 To Len(obj.Text)
　　　　　Select Case Mid(obj.Text, i, 1)
　　　　　　　Case """" 'リテラル"対応
　　　　　　　　　dQuot = Not dQuot
　　　　　　　Case "'" 'シート名'対応
　　　　　　　　　If Not dQuot Then sQuot = Not sQuot
　　　　　　　Case "("
　　　　　　　　　If Not (dQuot Or sQuot) Then
　 '閉じ括弧の位置を取得
　　　　　　　　　　ix = getPairIndex(obj.Text, i)
　 '閉じ括弧があり、引数が入っている場合
　　　　　　　　　　If ix > 0 And ix > i + 1 Then
　　　　　　　　　　　　lv = lv + 1
　　　　　　　　　　　　obj.Shape.TextFrame.Characters( _
　　　　　　　　　　　　　　Start:=i + 1, _
　　　　　　　　　　　　　　Length:=ix - i - 1).Font.Color _
　　　　　　　　　　　　　　= getNestColor(lv)
　　　　　　　　　　End If
　　　　　　　　　End If
　　　　　　　Case ")"
　　　　　　　　　If Not (dQuot Or sQuot) Then lv = lv - 1
　　　　　End Select
　　　Next
　End Sub
　 '開き(に対する閉じ)の文字位置を返す
　Private Function getPairIndex(ByVal aString As String, _
　　　　　　　　　　　　　　　　ByVal aStart As Long) As Long
　　　Dim i As Long, cnt As Long
　　　Dim dQuot As Boolean, sQuot As Boolean
　　　For i = aStart + 1 To Len(aString)
　　　　　Select Case Mid(aString, i, 1)
　　　　　　　Case """" 'リテラル"対応
　　　　　　　　　dQuot = Not dQuot
　　　　　　　Case "'" 'シート名'対応
　　　　　　　　　If Not dQuot Then sQuot = Not sQuot
　　　　　　　Case "("
　　　　　　　　　If Not (dQuot Or sQuot) Then cnt = cnt + 1
　　　　　　　Case ")"
　　　　　　　　　If Not (dQuot Or sQuot) Then
　　　　　　　　　　　If cnt = 0 Then
　　　　　　　　　　　　　getPairIndex = i
　　　　　　　　　　　　　Exit Function
　　　　　　　　　　　End If
　　　　　　　　　　　cnt = cnt - 1
　　　　　　　　　End If
　　　　　End Select
　　　Next
　End Function
　 '数式のネストの深さにより色を返す
　Private Function getNestColor(ByVal lv As Long) As Long
　　　Dim aryColor
　　　aryColor = Array(vbBlack, vbBlue, vbMagenta, vbGreen, rgbBrown, vbCyan, vbRed)
　 '7進にして色を繰り返すrgbDarkKhaki
　　　getNestColor = aryColor(lv Mod 7)
　End Function
大きく二つに分かれています。
　コメントを作成して数式をいれる、
　 addFormulaComment
　数式のネストを判定して色分けする、
　 setFontColor
　コメントの位置やフォントサイズ等は適宜修正してください。
　括弧()の対になっている位置の特定が少し面倒です。
　 getPairIndex
　確実に括弧()を対で見つけるのは結構大変で、
　正規表現等で一発で取得するのは恐らく無理ではないかと思いましたので、愚直に順に探すようにしています。
　色分けする色の指定は、
　 getNestColor
　このなかで配列にして使っています。
　7色分けです。
　さらにネストがあれば、この色を繰り返し使うようにしてみました。
　さすがに、そんなにネストしたら・・・とは思いますけど。
　基本の色定数を使っていますが、黄色は見づらいので代わりにrgbBrownを入れてみました。
　 Colorプロパティの設定値一覧
　塗りつぶし、文字色、等々の色指定は結構悩ましいものがあります、Excel2003までなら、ColoIndexで56色だけだったので簡単 でしたが、Excel2007以降は、フルカラーがつかえるようになった為、色指定が悩ましくなりました。Excelのフルカラーは、24ビットカラー （16,777,216色）、
　もちろん、RGB関数で好きな色合いを指定すれば、より見やすくなると思います。
　やってみた感じでは、なるべく色合いが交互になるようにした方が見やすい感じを受けました。
　色数および何色を使うかは、適宜変更してみてください。
　 ※数式の改行
　もともとの数式が改行されていれば、それがそのままコメントに出力されます。
　上図では、下の数式はもともとが改行されていたものです。
　ちなみにこの数式は、 ひらがな⇔カタカナの変換 で紹介している数式になります。
　「ひらがな」を「カタカナ」に、「カタカナ」を「ひらがな」に変換する方法の説明です。ひらがな→カタカナ変換 A1セル「にっぽんたろう」、これをB1セルに「ニッポンタロウ」と表示するには、B1セルに、=PHONETIC(A1) これで、「カタカナ」で表示されたと思います。
　上段の数式は、全く意味のない今回の結果を見せる為だけのサンプル数式です。
　ツイッターで、文字列としての()や、シート名の()もあるよという事でしたので、
　上記VBAは、これらにも対応するように修正したものになります。
　

セルの数式をネスト色分けしてコメント表示の使用例


　
Sub SampleMain()
　 'アクティブシートの数式が入っているセルを取得
　　　Dim formulaRange As Range
　　　On Error Resume Next
　 '数式のセル全部、もちろん特定セルでも良い
　　　Set formulaRange = Cells.SpecialCells(xlCellTypeFormulas)
　　　If Err Then Exit Sub
　　　On Error GoTo 0
　　　Application.ScreenUpdating = False
　 '最小化されているとCommentが正しく取得できないので
　　　Dim winState As Long
　　　winState = Application.WindowState
　　　Application.WindowState = xlNormal 'xlMaximizedでも良い
　 '数式が入っている全セルに数式コメントを作成
　　　Dim myRange As Range
　　　For Each myRange In formulaRange
　　　　　Call setNestColorComment(myRange)
　　　Next
　　　Application.WindowState = winState
　　　Application.ScreenUpdating = True
　End Sub
アクティブシートの計算式が入っている全セルを対象としています。
　特定セル範囲、例えばB列なら、
　Range("B:B").SpecialCells(xlCellTypeFormulas)
　このようにしてください。
　もし1セルだけの場合は、
　SpecialCellsはシート全セルになってしまうので、その場合はSpecialCellsは使わないようにしてください。

セルの数式をネスト色分けしてコメント表示の最後に

もともとはツイッターで数式のお題の解答で良く見かけていたものを真似してみました。
　ネストが深くなっても、きちんと色分けするように自分なりに工夫したものになります。
　ツイッターで数式を紹介するときに、自分でもやってみようというのが作成の動機です。
　とはいえ、そもそもあまり深くネストした数式は作らないほうが良いという事だけは申し添えておきます。 inserted by FC2 system