Excel2010のリボンに、Excel2000と同じプログラムコードのコピペでユーザー設定ボタンを生成する～02。（一応ツールバー単位で。ピボットテーブル一発作成ボタン等も追加。ドロップダウンでの階層化ボタンも追加。）

● Excel2010のリボンに、Excel2000と同じプログラムコードのコピペでユーザー設定ボタンを生成する～02。（一応ツールバー単位で。ピボットテーブル一発作成ボタン等も追加。ドロップダウンでの階層化ボタンも追加。）

※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。

※32bitの2010までの話です。2013、2016はテストしてません。（できるかもしれませんけど）

※関連記事
『～「マクロの記録」機能の応用：Excel2010のリボンに、Excel2003時代の古いメニューバーやメニューボタンを好きなように表示する方法。昔の印刷ダイアログ（懐かしい！）とか、余白設定の画面が出てきて笑えます。といいますか、やはり意外と便利な面もありました。（2010以降に慣れてしまわれた方はイマイチかもしれませんが・・・。～』
『「マクロ」のリボンへのメニューボタン化・関連の記事5つ』→1、2、3、4、5
『用語：ExcelやWordにおける「マクロ」とは？VBAと何が違う？（「ExcelやWord自身」は「マクロ」をどう判別・区別しているか？）Accessの場合は？』
　　
　　
↓ こんな感じのことができます。
　（↓ アドインタブが自動生成され、その中にツールバーが組み込まれます。
　　　Excel2003以前のCommandBar関連のコードを使うと勝手にこうなります。
　　　下図のように階層化ボタンを作ることも可能です。）

↑ このアドインタブによく使う機能をボタン化して置いておき、かつ、この「アドイン」タブが一番先頭でに開くように位置をかえておけば、相当、便利になると思います。
（例えば→こちら）
ユーザー設定に、フォントやセル書式、ウィンドウの固定、などのうち、一番よく使うメニューや、複合的な操作（複合的なレイアウト設定など）をするメニューなどを並べておけば、とても便利だと思います。

結果的に「リボンの効率性・操作性の悪さ」をかなり解消できると思います。アドインでもないので、Excel起動時に起動が遅くなることもありません。

「アドイン」タブが一番先頭でに開くように位置をかえるには、リボンの設定で下図のように、▲▼のボタンで上下に動かして、一番上までもっていって、OKします。

下図のようになります。

（コピーや切り取り、ズーム、いきなり印刷、などの各種ボタンは、他の組み込みツールバーからコピーしたものです。やっぱり、こういうスタイルが一番操作がスムーズです。）
※コピーじゃなくても、ID番号でいきなり表示することも可能です。詳しくは→こちら。

また、クイックツールバーだけだと「文言」が登録できないので、文言が見たいものをリボンにボタン化し、文言が必要ないものをクイックツールバーにボタン化・・・、と分けて併用すれば、さらに便利になると思います。（リボンの側のボタンのアイコンの絵も変えられます。絵の番号は、こちらのWebページを参考にあらかじめ絵の番号を調べておきます。後述のプログラムの「.FaceId =×××」の部分です。）

※下図のようにボタンアイコンの絵には、オリジナルの絵を、イミディエイトで1行コードで設定（コピペ処理）することも可能です。

　　
　　
目次
　★ はじめに
　★ 使い道
　★ PERSONAL.XLS（xlsb）を配置する場所
　★ リボンの中に自動生成される単位
　★ ツールバーの削除の方法
　★ ボタンの増やし方の方法
　★ ボタンのアイコンの絵の変更方法
　★ ボタンのアイコンの絵を自作のビットマップの絵に変更する方法
　★ テストコード01
　★ ツールバーに、階層化したドロップダウンのメニューボタンを追加する例
　★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード
※Shift＋TABキー、もしくは、Homeキー、Homeキー＋TAB数回、を押すと、目次付近に戻れます。
　　
　　
※こちらは「パート02」です。「パート01」は→こちら。
パート01も「補足」に結構重要なことが書いてありますのでそちらもご覧になってみてください。
　　
　　
★ はじめに

例えば次のようなことをして、Excelでの作業の効率化を図ることができます。

(01)コピー、貼り付け、などのよく使うボタンをリボンの「アドイン」タブに自動生成
（「アドイン」タブは勝手に生成されるので「アドイン」タブ用のプログラムコードは不要です。）
(02)VBAプログラムコード（プロシージャ）をコマンドボタン化して、リボンの「アドイン」タブに自動生成（特にPERSONAL.XLSの内容を）

具体的には次のようなことができます。

リボンに「アドイン」タブと「ツールバー01」というツールバーを自動生成されるようにします。また、各ボタンは通常のコマンドやVBAプログラムと紐付けされていて、
・コピー、
・値の貼り付け、
・選択範囲を「hh:mm:ss」形式のセル書式にする、
・選択範囲を「yyyy/mm/dd」形式にする、
といったことなどができます。
（※「アドイン」タブは、2010などの場合はツールバーをVBAで追加すると、勝手に作られるので、「アドイン」タブを作るプログラムは要りません。郵便番号変換ウィザードをインストールしてある場合も勝手に「アドイン」タブができていると思いますが、その場合はそこにツールバーの内容が組み込まれていきます。2003以前の場合はツールバーだけが普通に追加されて表示されます。）

クイックアクセスツールバーとほとんど同じ感じになりますが、メニューボタンとVBAプログラムを紐付けすることにより、細かい制御ができるボタンを、クイックツールバーよりもかなり多く作れます。また、ボタンと名前（ボタンの文言）の両方を表示することができ、少し見やすくなります。
クイックツールバーもすごく便利なのですが、デフォルトの機能ではアイコン絵が変えられないのとボタンの文言が設定できないのでボタンが増えたときに分かりにくくなってしまいます。

なので、クイックアクセスツールバーの代わりに、2003スタイルのツールバーで代用します。2010でも2003用のツールバー作成プログラムが動きますし（自動的に「アドイン」タブができてその中に作成されます）、XMLを使わずに済むのでラクと言えば楽かもしれません。XMLのエディタやらなんやらを使うよりは、バージョン2000から共通のやり方でVBAでやってしまうほうが面倒は無いと言えば無いかもしれません。好みの問題化とは思いますが・・・。
リボンのタブを切り替えるのも面倒な、本当によく使う操作はクイックアクセスツールバーで、その他のよく使う機能は、「アドイン」タブにVBAでボタン化する、という2本柱で行くのも良いと思います。

なお、ボタンを押したときに動かすプログラム（プロシージャ）は、
C:\Users\ユーザー名\AppData\Roaming\Microsoft\Excel\XLSTART というフォルダの中に、
「PERSONAL.XLS」というファイルを作って、その中に書きます。

そして、そのプログラム（プロシージャ）とメニューボタンを、これまたVBAプログラミングで自動紐付けさせます。

今回ここでしている作業はそういった自動作業となります。
　　
　　
★ 使い道

例えば「マクロの記録」で作ったマクロを、「アドインタブに2003のコードでボタン追加」したりクイックツールバーに登録すると、「リボン系のアドイン」と違って起動時に読み込む必要がないので、Excelの起動が遅くなったりするようなことがなく、便利です。
以下のような使い道があると思います。

(01)「マクロの記録」で自動的に作ったマクロを登録する。
特に、セルの値などをいじらないような処理、たとえば、以下のような処理を自動化したいときにとても便利です。
・度重なるレイアウト変更（頻度が多い定型的なレイアウト変更）
・同様のセル書式設定
・同様のウィンドウの固定場所の変更や子ウィンドウの分割その他
・同様の「いつも決まったオートシェイプの作成や境界線の変更、フォント設定の変更」など
・逆に、頻度が少なすぎて処理内容を忘れてしまいがちな上記のようなセルの値の編集をしないような処理
・マイクロソフトのOfficeは「リボン」になったせいで、2クリックも3クリックも操作が増えて操作が遅くならざるをえなくなってしまったので、例えば通常メニューのダイアログをリボン経由でワンクリックで出したい、などのとき。

※ボタンとしての登録が、自分では難しかったら、以下の記事を誰か分かる人に読んでもらってやってもらってください。
『「マクロ」のリボンへのメニューボタン化・関連の記事5つ』→1、2、3、4、5
『用語：ExcelやWordにおける「マクロ」とは？VBAと何が違う？（「ExcelやWord自身」は「マクロ」をどう判別・区別しているか？）Accessの場合は？』

※マクロの自動記録とはすごく相性がいいので、ぜひ、併用してコスパアップに貢献してほしいです。必ずしも汎用的なマクロではなくても、部分的に自動化されるだけでも十分にコスパアップに貢献できると思います。
VBAがわからなくても自動化できるんですから。
もしマクロの記録でなんともならなかったら、「UWSC」も併用すると便利です。
UWSCについてはこちらと、こちらをご参照ください。
UWSCの自動実行ファイルも、本記事の「アドインタブの自作メニュー・ボタン」から呼び出すことが可能です。

(02)「マクロの記録」で作ったマクロを、一部、汎用的に作り替えたものを登録する
・ピボットをワンクリック一発で出して設定もしてしまう（「ソースとなる表の行と列の可変化」や「ピボット自体の毎度行うオプション設定」など）

(03)リボンの編集だとXMLを覚えるのがめんどくさい。アドインタブへのツールバー登録なら、2003のコマンドバー(ツールバー）操作関連のコードがそのまま使える

(04)自分で作ったビットマップのアイコンを、ボタンのアイコンとしてちゃちゃちゃっと使いたい

　　
　　
★ PERSONAL.XLS（xlsb）を配置する場所
C:\Users\ユーザー名\AppData\Roaming\Microsoft\Excel\XLSTART

※「PERSONAL.XLS」の作り方
2010の場合、xlsb拡張子ですでに「PERSONAL.XLS」ではなくて「PERSONAL.XLSB」ができている場合もあります。その場合はこれ以降の処置は必要ありません。「PERSONAL.XLSB」は、「開発」→「マクロの記録」→マクロの保存先で「個人用マクロブック」となっている状態で「OK」することで自動作成されます。「C:\Users\ユーザー名\AppData\Roaming\Microsoft\Excel\XLSTART」を開いて、「PERSONAL.XLSB」ができていたら、新たにxlsを作る必要はありません。

xlsでやりたいときは次のようにします。（すでにある「PERSONAL.XLS」を使いたいときも途中から同じです。）
最初、xlsx拡張子として画面が開きますので、先に、マイドキュメントなどに空のxlsファイルを別名保存します。ファイル→名前を付けて保存→ファイルの種類のドロップダウンメニューを「Excel97-2003ブック（xls）」に変更→PERSONAL.XLSという名前で「OK」します。（Excel2010でも「PERSONAL.XLS」という名前でOKです。拡張子はxlsmではなくて「xls」です。）

空のxlsファイルができたら「C:\Users\ユーザー名\AppData\Roaming\Microsoft\Excel\XLSTART」というフォルダに、そのファイルを移動します。

なお、2007以降？の場合は、「xlsb」拡張子ほうのが本当みたいです。自動的に個人用マクロブックとして生成されるのが普通です。でもxls拡張子でも動きます。もしxlsで不具合が出るなら前述の容量で今度は空のxlsbファイルを作って、それにプログラムをインポートすればOKかと思います。（インポートできるのかな？できなかったら単純にモジュールごとにxlsからコピペでOKです。）

移動完了したら、いったんそのファイルを開いて「非表示」の設定にして上書き保存して閉じます。
「非表示」にしないと普通のExcelファイルを開いたときに「PERSONAL.XLS」もいっしょに画面に表示されてしまうためです。これで共用部品化設定が完了です。

非表示設定のしかたは以下のとおりです。
2007以降の場合は「表示」タブ→「ウィンドウ」グループ→「表示しない」でいいようです。
「表示しない」が無いように見えたら、アイコンだけ出ている状態かもしれません。画面を最大化するか横方向に目いっぱい広げるとアイコンと文言の両方が見えると思います。
2003以前の場合は、ウィンドウ→「表示しない」でOKです。

　　
　　
★ リボンの中に自動生成される単位
ツールバー単位（ツールバーの名前単位）
　　
　　
★ ツールバーの削除の方法
こちらのプログラムは、以前のパート01のものと違い、自動で目的のツールバーをいったん削除しますので、手動での削除は必要ありませんが、一応、手動の方法も書いておきます。

Excel2010の場合ですと、ツールバーのどのボタンの上でもいいので右クリックして「ユーザー設定のツールバーの削除」でOKです。

「アドイン」タブの中に単一のツールバーしかない場合、それを削除すると、同時に「アドイン」タブも消えます。

複数のツールバーが生成されていた場合、最後のツールバーが削除されると「アドイン」タブも消えます。

再度、プログラムでツールバーを自動生成すると、同名のツールバーが生成されます。
（本サンプルでは「ツールーバー01」ツールバー。）

※2019/02/09追記
おわりのほうの「★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード」を使ってもらってもOKです。
　　
　　
★ ボタンの増やし方の方法

新しくボタンのみを追加したい場合は、そのようにプログラム内容を追記します。
下記サンプル（「★ テストコード01」）だと、「CmdBarCelHennsyuuChkAndAdd01()」に６個めまでが書いてあるので、これを、同じようなコードを７つめ、８つめ、とボタンの登録のプログラムを追加し、そして、「CmdBarCelHennsyuuChkAndAdd01()」を実行します。

基本的には、(6)のようなカッコの中の数字を、７とか、８とかにして（連番になってないとエラーになるかもしれません）、「Newbar.Controls(7).OnAction = "PERSONAL.XLS!×××××"」の行の「×××××」のところに追加したいボタン動作のプロシージャの名前を書くだけです。「Newbar.Controls(7).Caption = "×××××(&C)"」行はボタンの文言になるのでここも「×××××」のところを好きな文言に書き換えます。（以下の例を参考に）
それに伴ってコメントも書き換えます。

例：7個目の場合
Newbar.Controls.Add ID:=2950
Newbar.Controls(7).Style = msoButtonIconAndCaption
Newbar.Controls(7).Caption = "×××××(&C)"　'ボタンの文言を好きな文言に設定
Newbar.Controls(7).OnAction = "PERSONAL.XLS!×××××"　'動かしたいプロシージャを設定

※本サンプルでは、ドロップダウンで階層化したメニューを7個めに追加したコードを最後にご紹介します。→ 　こちら

なお、こちらのプログラムは、以前のパート01のものと違い、自動で目的のツールバーをいったん削除しますので、手動での削除は必要ありません。自動的に、再度、同じ名前でツールバーが登録されます。

※2019/02/09追記
おわりのほうの「★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード」を使ってもらってもOKです。ツールバーをいったん消すことなくボタンの追加のみができます。
また、追加時に、「myBar.Controls(8).FaceId = 4 」みたいなコードを足していただくと、ボタンのアイコンの絵を変更することができます。「4」は絵の番号でこの例ではプリンタの絵です。
ボタンの絵の番号についてはこちらのWebページをご参考にしてください。
　　
　　
★ ボタンのアイコンの絵の変更方法

※2019/02/09追記
おわりのほうの「★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード」の、「CmdBtnOnlyIcnChange01()」プロシージャなどを使ってもらうと変えることができます。

イミディエイトウィンドウで
Commandbars("ツールバー名").Controls(変えたいボタンの番号).FaceID = 変えたい絵の番号
とやってもOKです。
（例：Commandbars("ツールバー01").Controls(8).FaceID = 4）

変更には絵の番号が必要なのですが、それは、こちら（OfficeTANAKA様）やこちら（リボンの君とSuyamaSoftさま）のWebページをご参考にしてください。

また、絵を変えたいボタンの番号やそのボタンを含んでいるツールバーの名前なども必要なのですが、それは「BtnName_n_Index_Check01()」プロシージャなどや「BarName_n_Index_Check01()」プロシージャなどでチェックしてみてください。
　　
　　
★ ボタンのアイコンの絵を自作のビットマップの絵に変更する方法

流れとしては、ペイントで絵を描いて、それをコピーしてクリップボードへ送り、それを「PasteFace」メソッドでボタンに貼り付けます。「PasteFace」はクリップボードにある画像（多分BMP）をボタンに貼り付けてくれる命令です。

(01)ペイントを開きます。
(02)16×16のキャンバス設定にします。
(03)あまりにちっこいので、最大限まで拡大表示します。
(04)好きな絵を描きます。
(05)一応、いったん保存します。（Officeやパソコンの再インストール後に同じ絵をアイコン復活させたいなら。）
(06)再度描いた絵を開いて、すべて選択したのち、「コピー」もします。（クリップボードに描いた画像を送る
(07)イミディエイトウィンドウで以下のようにコードを実行
Commandbars("対象のツールバー名").Controls(絵を変えたいボタンの番号).PasteFace

例：Commandbars("ツールバー01").Controls(8).PasteFace

※キャンバスの大きさは、16×16よりも多少大きくても大丈夫ですが、あまりに大きいとコードを実行しても絵が正常に表示されません。
50×50前後くらいでご自分でも色々と試してみてください。

そのほか、こちら↓もご参考に。（2007以降でしか使えない技ですが・・・。）

http://suyamasoft.blue.coocan.jp/Ribbon/ReverseResolution/get_idMso/index.html

※対象のツールバーの名前や、絵を変えたいボタンの番号を調べるには、おわりのほうの「★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード」を見てください。
その中の、「BtnName_n_Index_Check01()」プロシージャや「BarName_n_Index_Check01()」プロシージャなどであらかじめチェックしておきます。
　　
　　
★ テストコード01
以下のコードを標準モジュールにコピペして実行すると、「アドイン」タブと「ツールバー01」ツールバーが出来上がります。

'
'
'######################################################################
'######################################################################
'######################################################################

'「ツールバー01」ツールバーが存在するかをチェックして
'あればいったん消してから再作成するプログラムです。
'ボタンの表示形式を「イメージとテキスト」にします。
'ループで変数利用しています。
'自動的に目的のツールバーをいったん消してから再作成するので、
'メンテやコマンドボタン化に向くのではないかと思います。
'すでにあるツールバーにボタンだけを追加するようなプログラムは、各ボタンについての
'「あるか無いか」のチェックプログラムが要りそうで面倒くさいためやりません。

'######################################################################
'######################################################################
'######################################################################

Sub CmdBarCelHennsyuuChkAndAdd03()
    
    Dim Newbar As CommandBar, i As Long, C
    Dim oldBar As CommandBar
'    Set Newbar = CommandBars.Add

    Dim StrBarChkTxt As String
    
    '作りたいツールバーの名前を、ここで「ツールバー01」決めておきます。
    'ここで別の名前に書き換えれば、たとえボタンの内容が同じだったとしても
    '別のツールバーとして、リボンの「アドイン」タブに新しく生成されます。
    StrBarChkTxt = "ツールバー01"
    
    For Each C In CommandBars
        If C.Name = StrBarChkTxt Then
            '既に、「StrBarChkTxt = "ツールバーの名前"」で指定した名前のツールバーが存在したら
            'いったん消す。
            Set oldBar = CommandBars(StrBarChkTxt)
            oldBar.Delete
        Else
            
            '見つからねば次へ
        End If
    Next C
    
    '直前のループを最後まで実行して指定した名前にのツールバーが見つからなかった時はここに来るので、
    '必要に応じて以下のメッセージを発する。
'    MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようです。再作成してください。"
'    MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようですので再作成します。"
    
    Set Newbar = CommandBars.Add
    Newbar.Name = StrBarChkTxt                 'ツールバーの名前を設定します

    '1つめのボタンを追加
    Newbar.Controls.Add ID:=19    '本ツールバーの1つ目のボタンとして「コピー」を追加します
    Newbar.Controls(1).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。

    '2つめのボタンを追加
    Newbar.Controls.Add ID:=370    '本ツールバーの2つ目のボタン「値の貼り付け」を追加します
    Newbar.Controls(2).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。

    Newbar.Controls.Add ID:=2950    '本ツールバーの3つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(3).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(3).Caption = "hms(&C)"                ' ボタンの「テキスト」部分を、「hms(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(3).OnAction = "PERSONAL.XLS!cell_jikoku_hh_mm_ss"  ' ボタンを「PERSONAL.XLS」の「cell_jikoku_hh_mm_ss」プロシージャと関連付ける

    Newbar.Controls.Add ID:=2950    '本ツールバーの4つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(4).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(4).Caption = "ymd(&C)"                ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(4).OnAction = "PERSONAL.XLS!cell_hiduke_yyyy_mm_dd"  ' ボタンを「PERSONAL.XLS」の「cell_hiduke_yyyy_mm_dd」プロシージャと関連付ける

    Newbar.Controls.Add ID:=2950    '本ツールバーの5つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(5).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(5).Caption = "直前セル埋(&C)"                ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(5).OnAction = "PERSONAL.XLS!EmpCelFillPrevVle"  ' ボタンを「PERSONAL.XLS」の「EmpCelFillPrevVle」プロシージャと関連付ける

    Newbar.Controls.Add ID:=2950    '本ツールバーの6つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(6).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(6).Caption = "Pvt生成01(&C)"                ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01"  ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける
     
    Newbar.Visible = True


End Sub
'
'################################################################
'################################################################
'################################################################

'以降、各ボタン用のコード（プロシージャ）です。
'一部、使わないプロシージャもあります。
'今回使うのは、cell_hiduke_yyyy_mm_dd() と、
'cell_hiduke_yyyy_mm_dd()の２つだけです。

'################################################################
'################################################################
'################################################################

'セルを数値の設定にする（今回は使いません）
Sub 列全体セル編集数値()
    Selection.NumberFormatLocal = "#,##0_ "
End Sub

'時刻化するボタン用のプロシージャ（今回使います。）
Sub cell_jikoku_hh_mm_ss()
    Selection.NumberFormatLocal = "hh:mm:ss"
End Sub

'ユーザー定義の「yyyy/mm/dd」化するボタン用のプロシージャ（今回使います。）
Sub cell_hiduke_yyyy_mm_dd()
    Selection.NumberFormatLocal = "yyyy/mm/dd"
End Sub

'複数の子ウィンドウ上下に整列する（今回は使いません）
Sub win_seiretu_jyouge()
    Windows.Arrange ArrangeStyle:=xlHorizontal
End Sub

'複数の子ウィンドウ左右に整列する（今回は使いません）
Sub win_seiretu_sayuu()
    Windows.Arrange ArrangeStyle:=xlVertical
End Sub
'
'
'################################################################
'アクティブセルの列の空白セルを、前の行のセルの値で埋めるプログラムです。
'
'ピボットテーブルの結果を他のシートにコピペして、更に何か集計をしたい時や、
'ピボットテーブルを半利用して
'「クロス集計表をリスト形式の表にできるだけ速く直す」処理をする場合、
'等々に使えます｡
'
'################################################################
 
Sub EmpCelFillPrevVle()
 
    Dim Celladr01           As String
    Dim FldNum01            As String
    Dim LastCelRowNum01     As Variant 'インプットボックスで使います。キャンセル時に文字列型のデータ（空文字）が代入されるのですが、その際変数が数値型だとエラーになってしまうため、バリアント型を使います。
    Dim answ01              As Integer
    Dim cnt01               As Long
    Dim CellVle             As Variant
 
 
    'アクティブセルのセルアドレスを取得
    Celladr01 = ActiveCell.Address
    
    'Mid関数にて、アクティブセルの列番号（AとかBとかC・・・とか）を取得
    FldNum01 = Mid(Celladr01, 2, 1)
 
 
    '次へ進んでいいか？最終行の行番号はチェックしてあるか？などのエンドユーザへの確認
    'answ01 の中には、ユーザーがどのボタンを押したかの応えの情報（番号）が格納されます。
    'これはMsgBox関数の中でのきまりで、「はい」が押されたら「6」、「いいえ」が押されたら「7」、と決められています。
    answ01 = MsgBox("空白を埋める予定の列は　" & FldNum01 & "　列 です。本当にこの列でいいですか？" _
            & vbCrLf & "" _
            & vbCrLf & "※最終セルの行番号をまだ調べてなかったら 「いいえ」で中断して調べてから" _
            & vbCrLf & "　再操作してください。" _
            & vbCrLf & "", vbYesNo + vbExclamation + vbDefaultButton2, "最後の確認")
 
 
    'OK(=6=はい)なら次へ。中断(=7=ダメ=いいえ)ならプログラムを抜ける（＝終わる）。
    If answ01 = 6 Then
    
    ElseIf answ01 = 7 Then
        Exit Sub
    Else
        Exit Sub
    End If
    
    
    '最終セルの行番号（1とか、2とか、100とか、1000とか・・・）、
    'つまりどこまでやるかをユーザーに聞いて取得する
    LastCelRowNum01 = InputBox("最終セルの行番号を入力してください。")
    
    'インプットボックスでキャンセルされたときの処理
    'MsgBoxキャンセルされると「空文字」の「""」を返してきます。
    'で、それが変数LastCelRowNum01に代入されるので、もし
    '変数LastCelRowNum01に「""」が代入されていればキャンセルされた、
    'と判断することができます。そのための処理をここでやります。
    'それをやっておかないと、エラーが出てしまうのでエラー回避の意味でもやっておきます。
    If LastCelRowNum01 = "" Then
        MsgBox "処理を中断します。"
        Exit Sub
    Else
    
    End If
   
    '●メイン処理：今居るセルが空白だったら、前のセルの値で埋めて、最終セルまで行く、という処理。
    For cnt01 = 2 To LastCelRowNum01       '←行番号が「2」～「最終セルの番号」まで繰り返す、の意味です。
    
        'アクティブセルの列の cnt01 行めに移動
        Range(FldNum01 & cnt01).Select
        
        '空白かそうでないかを判断するために、
        '変数 CellVle に 現在のセルの値を代入します。
        CellVle = Range(FldNum01 & cnt01).Value
        
        
        'ここでCellVle（アクティブセル） の値が空白かどうかを調べてそれぞれの自動処理をします。
        If CellVle = "" Then
            'もし「CellVle の値＝今のセル」が空白だったら・・・
            '今居るセルに、前のセルの値と同じ値を代入します。
            Range(FldNum01 & cnt01).Value = Range(FldNum01 & cnt01 - 1).Value
        Else
            '空白じゃないときの処理。
            '何もせずスルーします。
        End If
        
    
    Next cnt01          '最終セルじゃなければ次のセルへ移動する準備をします（●メイン処理の最初「For cnt01 = 2 To LastCelRowNum01」の行に戻ります。）
 
End Sub
'
'

'################################################################
'ピボットの自動作成（2010用）
'2003タイプの表示形式にしてあります。
'ソースの表は自動的に名前の定義をするので、行や列が増減しても
'ソースの範囲の再設定をする必要はありません。
'できあがったピボットには、「ここに行のフィールドをドラッグします」などの
'文言が表示されます。
'空のシートで動かすとエラーになりますのでエラー回避コードは自作してください。
'################################################################

Sub Off2010MakePvt01()

    Dim ObjCache        As PivotCache
    Dim ObjTable        As PivotTable
    Dim StrActvShtName  As String
    
    
    '現在のシート（アクティブなシート）の行と列が増えても
    'ピボットの再設定をしなくても済むようにする処置
    '「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」にて
    '名前の定義の操作をして、ソースとなる表に「pvtsrc01」という名前を付けます。
'    ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _
'        "=OFFSET(データセット1!R1C1,0,0,COUNTA(データセット1!C1),COUNTA(データセット1!R1))"
    StrActvShtName = ActiveSheet.Name
    ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _
        "=OFFSET(" & StrActvShtName & "!R1C1,0,0,COUNTA(" & StrActvShtName & "!C1),COUNTA(" & StrActvShtName & "!R1))"
    ActiveWorkbook.Names("pvtsrc01").Comment = ""


    'ピボットキャッシュの作成（名前の定義をした「pvtsrc01」をソースにして。）
'    Set ObjCache = ActiveWorkbook.PivotCaches.Create _
'    (SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion)
    Set ObjCache = ActiveWorkbook.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:="pvtsrc01")
        
        
    '新しいシートの作成
    Worksheets.Add              '新しいシートの作成
    ActiveSheet.Name = "Pvt01"  'そのシートの名前を「Pvt01」にする
    
    
    '新しいシートへの空のピボットテーブルの作成
    Set ObjTable = ObjCache.CreatePivotTable _
    (TableDestination:=Worksheets("Pvt01").Range("A3"), TableName:="test01Pivot")
    

    '古いタイプのピボットの表示・操作性への切り替え
    '（古いタイプでなくても良ければここは５行全部をコメントアウトします）
    Worksheets("Pvt01").Range("A3").Select          '新しく作ったピボットの任意のセルを選択
    With ActiveSheet.PivotTables("test01Pivot")
        .HasAutoFormat = False
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
    End With
    
'    '★★ 行ラベルを設定して、集計したい列で集計する
'    '     （実際に使いたいときは以降の部分をコメントアウトして試してみてください。）
'     ObjTable.AddFields RowFields:=Array("行見出しにしたいアイテムのある列名")
'         '     ↑ 行ラベルの設定（１つだけの場合。2段、3段、なら、多分だけど、Array("1段目の列名","2段目の列名","3段目の列名")でやる。Columnも同じだと思う。多分。）
'     ObjTable.AddDataField ObjTable.PivotFields("数値合計したい列名"), "合計結果"
'         '     ↑ 「合計結果」という名前で集計する

End Sub

'################################################################
'ピボットの自動作成（2000用）（今回は使いません）
'2003タイプの表示形式にしてあります。
'ソースの表は自動的に名前の定義をするので、行や列が増減しても
'ソースの範囲の再設定をする必要はありません。
'ただし、できあがったピボットには、「ここに行のフィールドをドラッグします」
'などの文言が表示され「ません」。
'空のシートで動かすとエラーになりますのでエラー回避コードは自作してください。
'################################################################

Sub Excel2k_MakePvt01()
 
    Dim ObjCache        As PivotCache
    Dim ObjTable        As PivotTable
    Dim StrActvShtName  As String
    
    
    '現在のシート（アクティブなシート）の行と列が増えてもピボットソースの再設定をしなくても
    '済むようにする処置。
    '具体的には、「名前の定義」の機能にて、
    '範囲の設定に「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」を使って、
    'ソースとなる表に「pvtsrc01」という名前を付けます。
    '（ピボットのソース範囲の指定には、この「pvtsrc01」という名前を使います。）
    StrActvShtName = ActiveSheet.Name
    ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _
        "=OFFSET(" & StrActvShtName & "!R1C1,0,0,COUNTA(" & StrActvShtName & "!C1),COUNTA(" & StrActvShtName & "!R1))"
    'ActiveWorkbook.Names("pvtsrc01").Comment = ""
        
        
    '新しいシートの作成
    Worksheets.Add              '新しいシートの作成
    ActiveSheet.Name = "Pvt01"  'そのシートの名前を「Pvt01」にする
    
    
'    '新しいシートへの空のピボットテーブルの作成
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
        SourceData:="pvtsrc01").CreatePivotTable _
        TableDestination:="Pvt01!R3C1", _
        TableName:="aaa"
        
 
    ActiveSheet.PivotTables("aaa").SmallGrid = False '「ここに・・・うんぬん」を表示
 


'    '★★ ピボットテーブルで行や列を設定して集計をする例。
'    '     （実際に使いたいときは以降の部分をコメントアウトして試してみてください。）
'    '以下の例は、ソースの表に「顧客ID」「氏名」「住所01」「単価」「数量」という列がある場合。
'
'    '作ったピボットテーブルをオブジェクト変数に代入。
'    Set ObjTable = ActiveSheet.PivotTables("aaa")
'
'    '「顧客ID」列を、1段目の行ラベルに設定。
'    With ObjTable.PivotFields("顧客ID")
'        .Orientation = xlRowField
'        .Position = 1
'    End With
'
'    '「氏名」列を、2段目の行ラベルに設定。
'    With ObjTable.PivotFields("氏名")
'        .Orientation = xlRowField
'        .Position = 2
'    End With
'
'    '「住所01」列を、1段目の列ラベルに設定。
'    With ObjTable.PivotFields("住所01")
'        .Orientation = xlColumnField
'        .Position = 1
'    End With
'
'    '「単価」列を、1段目の集計フィールドに設定。
'    With ObjTable.PivotFields("単価")
'        .Orientation = xlDataField
'        .Position = 1
'    End With
'
'    '「数量」列を、2段目の集計フィールドに設定。
'    With ObjTable.PivotFields("数量")
'        .Orientation = xlDataField
'        .Position = 2
'    End With
    

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

313

314

315

316

317

318

319

320

321

322

323

324

325

326

327

328

329

330

331

332

333

334

335

336

337

338

339

340

341

342

343

344

345

346

347

348

349

350

351

352

353

354

355

356

357

358

359

360

361

362

363

364

'######################################################################

'「ツールバー01」ツールバーが存在するかをチェックして

'あればいったん消してから再作成するプログラムです。

'ボタンの表示形式を「イメージとテキスト」にします。

'ループで変数利用しています。

'自動的に目的のツールバーをいったん消してから再作成するので、

'メンテやコマンドボタン化に向くのではないかと思います。

'すでにあるツールバーにボタンだけを追加するようなプログラムは、各ボタンについての

'「あるか無いか」のチェックプログラムが要りそうで面倒くさいためやりません。

'######################################################################

Sub CmdBarCelHennsyuuChkAndAdd03()

Dim Newbar As CommandBar, i As Long, C

Dim oldBar As CommandBar

' Set Newbar = CommandBars.Add

Dim StrBarChkTxt As String

'作りたいツールバーの名前を、ここで「ツールバー01」決めておきます。

'ここで別の名前に書き換えれば、たとえボタンの内容が同じだったとしても

'別のツールバーとして、リボンの「アドイン」タブに新しく生成されます。

StrBarChkTxt = "ツールバー01"

For Each C In CommandBars

If C.Name = StrBarChkTxt Then

'既に、「StrBarChkTxt = "ツールバーの名前"」で指定した名前のツールバーが存在したら

'いったん消す。

Set oldBar = CommandBars(StrBarChkTxt)

oldBar.Delete

Else

'見つからねば次へ

End If

Next C

'直前のループを最後まで実行して指定した名前にのツールバーが見つからなかった時はここに来るので、

'必要に応じて以下のメッセージを発する。

' MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようです。再作成してください。"

' MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようですので再作成します。"

Set Newbar = CommandBars.Add

Newbar.Name = StrBarChkTxt 'ツールバーの名前を設定します

'1つめのボタンを追加

Newbar.Controls.Add ID:=19 '本ツールバーの1つ目のボタンとして「コピー」を追加します

Newbar.Controls(1).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

'2つめのボタンを追加

Newbar.Controls.Add ID:=370 '本ツールバーの2つ目のボタン「値の貼り付け」を追加します

Newbar.Controls(2).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls.Add ID:=2950 '本ツールバーの3つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(3).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(3).Caption = "hms(&C)" ' ボタンの「テキスト」部分を、「hms(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(3).OnAction = "PERSONAL.XLS!cell_jikoku_hh_mm_ss" ' ボタンを「PERSONAL.XLS」の「cell_jikoku_hh_mm_ss」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの4つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(4).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(4).Caption = "ymd(&C)" ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(4).OnAction = "PERSONAL.XLS!cell_hiduke_yyyy_mm_dd" ' ボタンを「PERSONAL.XLS」の「cell_hiduke_yyyy_mm_dd」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの5つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(5).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(5).Caption = "直前セル埋(&C)" ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(5).OnAction = "PERSONAL.XLS!EmpCelFillPrevVle" ' ボタンを「PERSONAL.XLS」の「EmpCelFillPrevVle」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの6つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(6).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(6).Caption = "Pvt生成01(&C)" ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01" ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける

Newbar.Visible = True

End Sub

'################################################################

'以降、各ボタン用のコード（プロシージャ）です。

'一部、使わないプロシージャもあります。

'今回使うのは、cell_hiduke_yyyy_mm_dd() と、

'cell_hiduke_yyyy_mm_dd()の２つだけです。

'################################################################

'セルを数値の設定にする（今回は使いません）

Sub 列全体セル編集数値()

Selection.NumberFormatLocal = "#,##0_ "

End Sub

'時刻化するボタン用のプロシージャ（今回使います。）

Sub cell_jikoku_hh_mm_ss()

Selection.NumberFormatLocal = "hh:mm:ss"

End Sub

'ユーザー定義の「yyyy/mm/dd」化するボタン用のプロシージャ（今回使います。）

Sub cell_hiduke_yyyy_mm_dd()

Selection.NumberFormatLocal = "yyyy/mm/dd"

End Sub

'複数の子ウィンドウ上下に整列する（今回は使いません）

Sub win_seiretu_jyouge()

Windows.Arrange ArrangeStyle:=xlHorizontal

End Sub

'複数の子ウィンドウ左右に整列する（今回は使いません）

Sub win_seiretu_sayuu()

Windows.Arrange ArrangeStyle:=xlVertical

End Sub

'################################################################

'アクティブセルの列の空白セルを、前の行のセルの値で埋めるプログラムです。

'ピボットテーブルの結果を他のシートにコピペして、更に何か集計をしたい時や、

'ピボットテーブルを半利用して

'「クロス集計表をリスト形式の表にできるだけ速く直す」処理をする場合、

'等々に使えます｡

'################################################################

Sub EmpCelFillPrevVle()

Dim Celladr01 As String

Dim FldNum01 As String

Dim LastCelRowNum01 As Variant 'インプットボックスで使います。キャンセル時に文字列型のデータ（空文字）が代入されるのですが、その際変数が数値型だとエラーになってしまうため、バリアント型を使います。

Dim answ01 As Integer

Dim cnt01 As Long

Dim CellVle As Variant

'アクティブセルのセルアドレスを取得

Celladr01 = ActiveCell.Address

'Mid関数にて、アクティブセルの列番号（AとかBとかC・・・とか）を取得

FldNum01 = Mid(Celladr01, 2, 1)

'次へ進んでいいか？最終行の行番号はチェックしてあるか？などのエンドユーザへの確認

'answ01 の中には、ユーザーがどのボタンを押したかの応えの情報（番号）が格納されます。

'これはMsgBox関数の中でのきまりで、「はい」が押されたら「6」、「いいえ」が押されたら「7」、と決められています。

answ01 = MsgBox("空白を埋める予定の列は　" & FldNum01 & "　列です。本当にこの列でいいですか？" _

& vbCrLf & "" _

& vbCrLf & "※最終セルの行番号をまだ調べてなかったら「いいえ」で中断して調べてから" _

& vbCrLf & "　再操作してください。" _

& vbCrLf & "", vbYesNo + vbExclamation + vbDefaultButton2, "最後の確認")

'OK(=6=はい)なら次へ。中断(=7=ダメ=いいえ)ならプログラムを抜ける（＝終わる）。

If answ01 = 6 Then

ElseIf answ01 = 7 Then

Exit Sub

Else

Exit Sub

End If

'最終セルの行番号（1とか、2とか、100とか、1000とか・・・）、

'つまりどこまでやるかをユーザーに聞いて取得する

LastCelRowNum01 = InputBox("最終セルの行番号を入力してください。")

'インプットボックスでキャンセルされたときの処理

'MsgBoxキャンセルされると「空文字」の「""」を返してきます。

'で、それが変数LastCelRowNum01に代入されるので、もし

'変数LastCelRowNum01に「""」が代入されていればキャンセルされた、

'と判断することができます。そのための処理をここでやります。

'それをやっておかないと、エラーが出てしまうのでエラー回避の意味でもやっておきます。

If LastCelRowNum01 = "" Then

MsgBox "処理を中断します。"

Exit Sub

Else

End If

'●メイン処理：今居るセルが空白だったら、前のセルの値で埋めて、最終セルまで行く、という処理。

For cnt01 = 2 To LastCelRowNum01 '←行番号が「2」～「最終セルの番号」まで繰り返す、の意味です。

'アクティブセルの列の cnt01 行めに移動

Range(FldNum01 & cnt01).Select

'空白かそうでないかを判断するために、

'変数 CellVle に現在のセルの値を代入します。

CellVle = Range(FldNum01 & cnt01).Value

'ここでCellVle（アクティブセル）の値が空白かどうかを調べてそれぞれの自動処理をします。

If CellVle = "" Then

'もし「CellVle の値＝今のセル」が空白だったら・・・

'今居るセルに、前のセルの値と同じ値を代入します。

Range(FldNum01 & cnt01).Value = Range(FldNum01 & cnt01 - 1).Value

Else

'空白じゃないときの処理。

'何もせずスルーします。

End If

Next cnt01 '最終セルじゃなければ次のセルへ移動する準備をします（●メイン処理の最初「For cnt01 = 2 To LastCelRowNum01」の行に戻ります。）

End Sub

'################################################################

'ピボットの自動作成（2010用）

'2003タイプの表示形式にしてあります。

'ソースの表は自動的に名前の定義をするので、行や列が増減しても

'ソースの範囲の再設定をする必要はありません。

'できあがったピボットには、「ここに行のフィールドをドラッグします」などの

'文言が表示されます。

'空のシートで動かすとエラーになりますのでエラー回避コードは自作してください。

'################################################################

Sub Off2010MakePvt01()

Dim ObjCache As PivotCache

Dim ObjTable As PivotTable

Dim StrActvShtName As String

'現在のシート（アクティブなシート）の行と列が増えても

'ピボットの再設定をしなくても済むようにする処置

'「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」にて

'名前の定義の操作をして、ソースとなる表に「pvtsrc01」という名前を付けます。

' ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _

' "=OFFSET(データセット1!R1C1,0,0,COUNTA(データセット1!C1),COUNTA(データセット1!R1))"

StrActvShtName = ActiveSheet.Name

ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _

"=OFFSET(" & StrActvShtName & "!R1C1,0,0,COUNTA(" & StrActvShtName & "!C1),COUNTA(" & StrActvShtName & "!R1))"

ActiveWorkbook.Names("pvtsrc01").Comment = ""

'ピボットキャッシュの作成（名前の定義をした「pvtsrc01」をソースにして。）

' Set ObjCache = ActiveWorkbook.PivotCaches.Create _

' (SourceType:=xlDatabase, SourceData:=Range("A1").CurrentRegion)

Set ObjCache = ActiveWorkbook.PivotCaches.Create _

(SourceType:=xlDatabase, SourceData:="pvtsrc01")

'新しいシートの作成

Worksheets.Add '新しいシートの作成

ActiveSheet.Name = "Pvt01" 'そのシートの名前を「Pvt01」にする

'新しいシートへの空のピボットテーブルの作成

Set ObjTable = ObjCache.CreatePivotTable _

(TableDestination:=Worksheets("Pvt01").Range("A3"), TableName:="test01Pivot")

'古いタイプのピボットの表示・操作性への切り替え

'（古いタイプでなくても良ければここは５行全部をコメントアウトします）

Worksheets("Pvt01").Range("A3").Select '新しく作ったピボットの任意のセルを選択

With ActiveSheet.PivotTables("test01Pivot")

.HasAutoFormat = False

.InGridDropZones = True

.RowAxisLayout xlTabularRow

End With

' '★★ 行ラベルを設定して、集計したい列で集計する

' ' （実際に使いたいときは以降の部分をコメントアウトして試してみてください。）

' ObjTable.AddFields RowFields:=Array("行見出しにしたいアイテムのある列名")

' ' ↑ 行ラベルの設定（１つだけの場合。2段、3段、なら、多分だけど、Array("1段目の列名","2段目の列名","3段目の列名")でやる。Columnも同じだと思う。多分。）

' ObjTable.AddDataField ObjTable.PivotFields("数値合計したい列名"), "合計結果"

' ' ↑ 「合計結果」という名前で集計する

End Sub

'################################################################

'ピボットの自動作成（2000用）（今回は使いません）

'2003タイプの表示形式にしてあります。

'ソースの表は自動的に名前の定義をするので、行や列が増減しても

'ソースの範囲の再設定をする必要はありません。

'ただし、できあがったピボットには、「ここに行のフィールドをドラッグします」

'などの文言が表示され「ません」。

'空のシートで動かすとエラーになりますのでエラー回避コードは自作してください。

'################################################################

Sub Excel2k_MakePvt01()

Dim ObjCache As PivotCache

Dim ObjTable As PivotTable

Dim StrActvShtName As String

'現在のシート（アクティブなシート）の行と列が増えてもピボットソースの再設定をしなくても

'済むようにする処置。

'具体的には、「名前の定義」の機能にて、

'範囲の設定に「=OFFSET($A$1,0,0,COUNTA($A:$A),COUNTA($1:$1))」を使って、

'ソースとなる表に「pvtsrc01」という名前を付けます。

'（ピボットのソース範囲の指定には、この「pvtsrc01」という名前を使います。）

StrActvShtName = ActiveSheet.Name

ActiveWorkbook.Names.Add Name:="pvtsrc01", RefersToR1C1:= _

"=OFFSET(" & StrActvShtName & "!R1C1,0,0,COUNTA(" & StrActvShtName & "!C1),COUNTA(" & StrActvShtName & "!R1))"

'ActiveWorkbook.Names("pvtsrc01").Comment = ""

'新しいシートの作成

Worksheets.Add '新しいシートの作成

ActiveSheet.Name = "Pvt01" 'そのシートの名前を「Pvt01」にする

' '新しいシートへの空のピボットテーブルの作成

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _

SourceData:="pvtsrc01").CreatePivotTable _

TableDestination:="Pvt01!R3C1", _

TableName:="aaa"

ActiveSheet.PivotTables("aaa").SmallGrid = False '「ここに・・・うんぬん」を表示

' '★★ ピボットテーブルで行や列を設定して集計をする例。

' ' （実際に使いたいときは以降の部分をコメントアウトして試してみてください。）

' '以下の例は、ソースの表に「顧客ID」「氏名」「住所01」「単価」「数量」という列がある場合。

' '作ったピボットテーブルをオブジェクト変数に代入。

' Set ObjTable = ActiveSheet.PivotTables("aaa")

' '「顧客ID」列を、1段目の行ラベルに設定。

' With ObjTable.PivotFields("顧客ID")

' .Orientation = xlRowField

' .Position = 1

' End With

' '「氏名」列を、2段目の行ラベルに設定。

' With ObjTable.PivotFields("氏名")

' .Orientation = xlRowField

' .Position = 2

' End With

' '「住所01」列を、1段目の列ラベルに設定。

' With ObjTable.PivotFields("住所01")

' .Orientation = xlColumnField

' .Position = 1

' End With

' '「単価」列を、1段目の集計フィールドに設定。

' With ObjTable.PivotFields("単価")

' .Orientation = xlDataField

' .Position = 1

' End With

' '「数量」列を、2段目の集計フィールドに設定。

' With ObjTable.PivotFields("数量")

' .Orientation = xlDataField

' .Position = 2

' End With

End Sub

　　
　　
　　
　　
★ ツールバーに、階層化したドロップダウンのメニューボタンを追加する例

６個めまでは前述のコードとまったく同じです。
違うのは７個目以降だけです。なので、７個目以降のコードだけを前述の６個目の下から「Newbar.Visible = True」の行の間にコピペしてもOKです。

本サンプルでは、７個目のボタンをドロップダウン形式のメニューボタンにし、さらにその中の３個目も、ドロップダウン形式のメニューボタンにしました。
これで階層化ができるので、インターフェイスが少しすっきりできるのではないかと思います。
こちらのテストでは、Excel2000、Excel2010、どちらでも動きました。
（アイコンの絵の対応表が無いので絵は適当な番号で変えてあります。）

↓こんな感じになります。

では、以下、コードです。
標準モジュールにコピペするなどしてテストしてみてください。

※ボタンのアイコンの絵は、2003側で気に入った絵をみつけて、あらかじめその番号を調べておかないといけなかったと思います。たしか・・・。「.FaceId =×××」の部分です。うろ覚えですみません。

このアドインタブによく使う機能をボタン化して置いておき、かつ、このアドインタブが一番先頭でに開くように位置をかえておけば、相当、便利になると思います。
リボンの効率性の悪さをかなり解消できると思います。アドインでもないので、Excel起動時に起動が遅くなることもありません。

'
'
'######################################################################
'######################################################################
'######################################################################

'※※※「階層化ツールバー」用 ※※※

'「ツールバー01」ツールバーが存在するかをチェックして
'あればいったん消してから再作成するプログラムです。
'ボタンの表示形式を「イメージとテキスト」にします。
'ループで変数利用しています。
'自動的に目的のツールバーをいったん消してから再作成するので、
'メンテやコマンドボタン化に向くのではないかと思います。
'すでにあるツールバーにボタンだけを追加するようなプログラムは、各ボタンについての
'「あるか無いか」のチェックプログラムが要りそうで面倒くさいためやりません。
 
'######################################################################
'######################################################################
'######################################################################
 
Sub CmdBarCelHennsyuuChkAndAdd03()
    
    Dim Newbar As CommandBar, i As Long, C
    Dim oldBar As CommandBar
'    Set Newbar = CommandBars.Add
 
    Dim StrBarChkTxt As String
    
    '作りたいツールバーの名前を、ここで「ツールバー01」決めておきます。
    'ここで別の名前に書き換えれば、たとえボタンの内容が同じだったとしても
    '別のツールバーとして、リボンの「アドイン」タブに新しく生成されます。
    StrBarChkTxt = "ツールバー01"
    
    For Each C In CommandBars
        If C.Name = StrBarChkTxt Then
            '既に、「StrBarChkTxt = "ツールバーの名前"」で指定した名前のツールバーが存在したら
            'いったん消す。
            Set oldBar = CommandBars(StrBarChkTxt)
            oldBar.Delete
        Else
            
            '見つからねば次へ
        End If
    Next C
    
    '直前のループを最後まで実行して指定した名前にのツールバーが見つからなかった時はここに来るので、
    '必要に応じて以下のメッセージを発する。
'    MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようです。再作成してください。"
'    MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようですので再作成します。"
    
    Set Newbar = CommandBars.Add
    Newbar.Name = StrBarChkTxt                 'ツールバーの名前を設定します
 
    '1つめのボタンを追加
    Newbar.Controls.Add ID:=19    '本ツールバーの1つ目のボタンとして「コピー」を追加します
    Newbar.Controls(1).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
 
    '2つめのボタンを追加
    Newbar.Controls.Add ID:=370    '本ツールバーの2つ目のボタン「値の貼り付け」を追加します
    Newbar.Controls(2).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
 
    Newbar.Controls.Add ID:=2950    '本ツールバーの3つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(3).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(3).Caption = "hms(&C)"                ' ボタンの「テキスト」部分を、「hms(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(3).OnAction = "PERSONAL.XLS!cell_jikoku_hh_mm_ss"  ' ボタンを「PERSONAL.XLS」の「cell_jikoku_hh_mm_ss」プロシージャと関連付ける
 
    Newbar.Controls.Add ID:=2950    '本ツールバーの4つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(4).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(4).Caption = "ymd(&C)"                ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(4).OnAction = "PERSONAL.XLS!cell_hiduke_yyyy_mm_dd"  ' ボタンを「PERSONAL.XLS」の「cell_hiduke_yyyy_mm_dd」プロシージャと関連付ける
 
    Newbar.Controls.Add ID:=2950    '本ツールバーの5つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(5).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(5).Caption = "直前セル埋(&C)"                ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(5).OnAction = "PERSONAL.XLS!EmpCelFillPrevVle"  ' ボタンを「PERSONAL.XLS」の「EmpCelFillPrevVle」プロシージャと関連付ける
 
    Newbar.Controls.Add ID:=2950    '本ツールバーの6つ目のボタン「マクロ」ボタンを追加します
    Newbar.Controls(6).Style = msoButtonIconAndCaption    ' ボタンの表示形式を「イメージとテキスト」にする。
    Newbar.Controls(6).Caption = "Pvt生成01(&C)"                ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。
    Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01"  ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける
    Newbar.Controls(6).FaceId = 17

    'ドロップダウンメニューボタンの作成
    Newbar.Controls.Add ID:=1, Type:=10   '本ツールバーの7つ目のボタン「ドロップダウンメニュー」ボタンを追加します
'    Newbar.Controls(7).Style = msoButtonIconAndCaption                'ドロップダウンのボタンではエラーになるのでコメントアウトします。
    Newbar.Controls(7).Caption = "Pvt関連(&C)"                ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。
'    Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01"     'ドロップダウンのボタンではエラーになるのでコメントアウトします。
'    Newbar.Controls(7).FaceId = 17                                    'ドロップダウンのボタンではエラーになるのでコメントアウトします。

        'ドロップダウンメニューの中に、1つ目のマクロボタンを作成
        Newbar.Controls(7).Controls.Add ID:=2950
        Newbar.Controls(7).Controls(1).Style = msoButtonIconAndCaption
        Newbar.Controls(7).Controls(1).Caption = "Pvt生成02-Ver2000用コード(&C)"
        Newbar.Controls(7).Controls(1).OnAction = "PERSONAL.XLS!Excel2k_MakePvt01"  ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける
        Newbar.Controls(7).Controls(1).FaceId = 100
         
        'ドロップダウンメニューの中に、2つ目のマクロボタンを作成（テストのため、絵だけ変えて同じボタンにしちゃいました。）
        Newbar.Controls(7).Controls.Add ID:=2950
        Newbar.Controls(7).Controls(2).Style = msoButtonIconAndCaption
        Newbar.Controls(7).Controls(2).Caption = "Pvt生成02-Ver2000用コード(&C)"
        Newbar.Controls(7).Controls(2).OnAction = "PERSONAL.XLS!Excel2k_MakePvt01"  ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける
        Newbar.Controls(7).Controls(2).FaceId = 200
        
        '3つ目としてさらなるドロップダウンメニューの作成
        Newbar.Controls(7).Controls.Add ID:=1, Type:=10
        Newbar.Controls(7).Controls(3).Caption = "その他(&C)"
        
            'さらなるドロップダウンメニューの中に、1つ目のマクロボタンの作成
            Newbar.Controls(7).Controls(3).Controls.Add ID:=2950
            Newbar.Controls(7).Controls(3).Controls(1).Style = msoButtonIconAndCaption
            Newbar.Controls(7).Controls(3).Controls(1).Caption = "ウィンドウの整列-上下(&C)"
            Newbar.Controls(7).Controls(3).Controls(1).OnAction = "PERSONAL.XLS!win_seiretu_jyouge"  ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける
            Newbar.Controls(7).Controls(3).Controls(1).FaceId = 300


    Newbar.Visible = True
 
 
End Sub


'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

'######################################################################

'※※※「階層化ツールバー」用 ※※※

'「ツールバー01」ツールバーが存在するかをチェックして

'あればいったん消してから再作成するプログラムです。

'ボタンの表示形式を「イメージとテキスト」にします。

'ループで変数利用しています。

'自動的に目的のツールバーをいったん消してから再作成するので、

'メンテやコマンドボタン化に向くのではないかと思います。

'すでにあるツールバーにボタンだけを追加するようなプログラムは、各ボタンについての

'「あるか無いか」のチェックプログラムが要りそうで面倒くさいためやりません。

'######################################################################

Sub CmdBarCelHennsyuuChkAndAdd03()

Dim Newbar As CommandBar, i As Long, C

Dim oldBar As CommandBar

' Set Newbar = CommandBars.Add

Dim StrBarChkTxt As String

'作りたいツールバーの名前を、ここで「ツールバー01」決めておきます。

'ここで別の名前に書き換えれば、たとえボタンの内容が同じだったとしても

'別のツールバーとして、リボンの「アドイン」タブに新しく生成されます。

StrBarChkTxt = "ツールバー01"

For Each C In CommandBars

If C.Name = StrBarChkTxt Then

'既に、「StrBarChkTxt = "ツールバーの名前"」で指定した名前のツールバーが存在したら

'いったん消す。

Set oldBar = CommandBars(StrBarChkTxt)

oldBar.Delete

Else

'見つからねば次へ

End If

Next C

'直前のループを最後まで実行して指定した名前にのツールバーが見つからなかった時はここに来るので、

'必要に応じて以下のメッセージを発する。

' MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようです。再作成してください。"

' MsgBox "「" & StrBarChkTxt & "」ツールバーが消えてしまっているようですので再作成します。"

Set Newbar = CommandBars.Add

Newbar.Name = StrBarChkTxt 'ツールバーの名前を設定します

'1つめのボタンを追加

Newbar.Controls.Add ID:=19 '本ツールバーの1つ目のボタンとして「コピー」を追加します

Newbar.Controls(1).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

'2つめのボタンを追加

Newbar.Controls.Add ID:=370 '本ツールバーの2つ目のボタン「値の貼り付け」を追加します

Newbar.Controls(2).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls.Add ID:=2950 '本ツールバーの3つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(3).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(3).Caption = "hms(&C)" ' ボタンの「テキスト」部分を、「hms(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(3).OnAction = "PERSONAL.XLS!cell_jikoku_hh_mm_ss" ' ボタンを「PERSONAL.XLS」の「cell_jikoku_hh_mm_ss」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの4つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(4).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(4).Caption = "ymd(&C)" ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(4).OnAction = "PERSONAL.XLS!cell_hiduke_yyyy_mm_dd" ' ボタンを「PERSONAL.XLS」の「cell_hiduke_yyyy_mm_dd」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの5つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(5).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(5).Caption = "直前セル埋(&C)" ' ボタンの「テキスト」部分を、「ymd(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(5).OnAction = "PERSONAL.XLS!EmpCelFillPrevVle" ' ボタンを「PERSONAL.XLS」の「EmpCelFillPrevVle」プロシージャと関連付ける

Newbar.Controls.Add ID:=2950 '本ツールバーの6つ目のボタン「マクロ」ボタンを追加します

Newbar.Controls(6).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

Newbar.Controls(6).Caption = "Pvt生成01(&C)" ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。

Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01" ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける

Newbar.Controls(6).FaceId = 17

'ドロップダウンメニューボタンの作成

Newbar.Controls.Add ID:=1, Type:=10 '本ツールバーの7つ目のボタン「ドロップダウンメニュー」ボタンを追加します

' Newbar.Controls(7).Style = msoButtonIconAndCaption 'ドロップダウンのボタンではエラーになるのでコメントアウトします。

Newbar.Controls(7).Caption = "Pvt関連(&C)" ' ボタンの「テキスト」部分を、「Pvt生成01(&C)」に変更する。「(&C)」を付けないとエラーになる。

' Newbar.Controls(6).OnAction = "PERSONAL.XLS!Off2010MakePvt01" 'ドロップダウンのボタンではエラーになるのでコメントアウトします。

' Newbar.Controls(7).FaceId = 17 'ドロップダウンのボタンではエラーになるのでコメントアウトします。

'ドロップダウンメニューの中に、1つ目のマクロボタンを作成

Newbar.Controls(7).Controls.Add ID:=2950

Newbar.Controls(7).Controls(1).Style = msoButtonIconAndCaption

Newbar.Controls(7).Controls(1).Caption = "Pvt生成02-Ver2000用コード(&C)"

Newbar.Controls(7).Controls(1).OnAction = "PERSONAL.XLS!Excel2k_MakePvt01" ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける

Newbar.Controls(7).Controls(1).FaceId = 100

'ドロップダウンメニューの中に、2つ目のマクロボタンを作成（テストのため、絵だけ変えて同じボタンにしちゃいました。）

Newbar.Controls(7).Controls.Add ID:=2950

Newbar.Controls(7).Controls(2).Style = msoButtonIconAndCaption

Newbar.Controls(7).Controls(2).Caption = "Pvt生成02-Ver2000用コード(&C)"

Newbar.Controls(7).Controls(2).OnAction = "PERSONAL.XLS!Excel2k_MakePvt01" ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける

Newbar.Controls(7).Controls(2).FaceId = 200

'3つ目としてさらなるドロップダウンメニューの作成

Newbar.Controls(7).Controls.Add ID:=1, Type:=10

Newbar.Controls(7).Controls(3).Caption = "その他(&C)"

'さらなるドロップダウンメニューの中に、1つ目のマクロボタンの作成

Newbar.Controls(7).Controls(3).Controls.Add ID:=2950

Newbar.Controls(7).Controls(3).Controls(1).Style = msoButtonIconAndCaption

Newbar.Controls(7).Controls(3).Controls(1).Caption = "ウィンドウの整列-上下(&C)"

Newbar.Controls(7).Controls(3).Controls(1).OnAction = "PERSONAL.XLS!win_seiretu_jyouge" ' ボタンを「PERSONAL.XLS」の「Off2010MakePvt01」プロシージャと関連付ける

Newbar.Controls(7).Controls(3).Controls(1).FaceId = 300

Newbar.Visible = True

End Sub

★ 操作したいツールバーの削除やボタンなどについて調査、ボタンアイコンの絵の変更などのコード

'
'
'################################################################
'すべてのツールバーの名前とインデックス番号のチェック
'###############################################################

Sub BarName_n_Index_Check01()

    Dim ObjBar As CommandBar
    
    For Each ObjBar In CommandBars
        Debug.Print ObjBar.Name & "------" & ObjBar.Index
    Next ObjBar

End Sub



'################################################################
'「ツールバー01」の削除。
'削除したいツールバーの名前、もしくはインデックス番号は、
'BarName_n_Index_Check01()プロシージャなどで
'あらかじめチェックしておきます。
'################################################################

Sub bardel() 'ツールバー01 の削除

    Dim myBar As CommandBar  'おい、パソコンよ、ツールバーを代入するためのオブジェクト変数をメモリ上に作っとけ。
    
    '操作したいツールバーを、オブジェクト変数に代入して操作可能にします。
    '＝ここでは操作したいツールバーを、「ツールバー02」に指定して操作可能にします。
    'おい、パソコンよ、「ツールバー02」という名前のツールバーを、オブジェクト変数のmyBarに代入しろ。
    Set myBar = CommandBars("ツールバー02")
    
    '指定したツールバーの削除
    'おい、パソコンよ、オブジェクト変数に代入したツールバーを削除しろ。
    myBar.Delete

End Sub


'################################################################################
'ツールバーへのボタンのみの新規登録
'自分が追加したツールバーの名前か番号が分かれば、
'そこへボタンのみを新規登録することもできます。
'以下の例の「myBar.Controls(8)」の部分の「8」の値は、
'ボタンの数を数えて、すでに7個のボタンがあったら「8」にします。
'同じ番号がかぶると、文言が表示されなかったりとおかしなことになるようです。
'事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して
'現状のボタンの中をチェックしておいてもOKです。
'操作したいツールバーの名前、もしくはインデックス番号は、
'BarName_n_Index_Check01()プロシージャなどで
'あらかじめチェックしておきます。
'################################################################################

Sub CmdBtnOnlyAdd()

    Dim myBar As CommandBar         '操作対象のツールバーを代入するオブジェクト変数
    Dim myBarName As String         'ツールバーの名前を代入するための変数
    
    myBarName = "ツールバー01"      '操作したいツールバーの指定。ここでは「ツールバー01」を指定しています。
    
    
    '操作対象のツールバーをオブジェクト変数に代入します。
    'ここでの例では、「ツールバー01」を代入（＝操作可能状態に）します。
    Set myBar = CommandBars(myBarName)
    
    
    myBar.Controls.Add ID:=19                               '新規ボタンとして「コピー」を追加します
    myBar.Controls(8).Style = msoButtonIconAndCaption      ' ボタンの表示形式を「イメージとテキスト」にする。

    
End Sub



'################################################################################
'ツールバーへのボタンのみの削除
'自分が追加したツールバーの名前か番号が分かれば、
'そこへボタンのみを新規登録することもできます。
'以下の例の「myBar.Controls(8)」の部分の「8」の値は、
'ボタンの数を数えて、消したいボタンが8個目にあったら その番号を書きます。
'事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して
'現状のボタンの中をチェックしておいてもOKです。
'操作したいツールバーの名前、もしくはインデックス番号は、
'BarName_n_Index_Check01()プロシージャなどで
'あらかじめチェックしておきます。
'################################################################################

Sub CmdBtnOnlyDel()

    Dim myBar As CommandBar
    Dim myBarName As String
    
    myBarName = "ツールバー01"
    
    Set myBar = CommandBars(myBarName)
    myBar.Controls(8).Delete            ' 番号が「8」のボタンを削除。

    
End Sub

'#############################################################################
'ツールバーの中の、ボタンのキャプション（文言）とインデックス番号のチェック
'操作したいツールバーの名前、もしくはインデックス番号は、
'BarName_n_Index_Check01()プロシージャなどで
'あらかじめチェックしておきます。
'#############################################################################

Sub BtnName_n_Index_Check01()

    Dim ObjBar      As CommandBar
    Dim ObjBtn      As Object       '「CommandBarBottun」にしてしまうと、階層ボタンのところでエラーになるのでObjectのままにしておきます。階層ボタンは「CommandBarPopup」になるようです。
    Dim StrBarName  As String
    
    StrBarName = "ツールバー01"
    Set ObjBar = CommandBars(StrBarName)
    
    For Each ObjBtn In ObjBar.Controls
        Debug.Print ObjBtn.Caption & "------" & ObjBtn.Index
    Next ObjBtn

End Sub


'################################################################################
'ツールバーへのボタンのアイコンの絵のみを変える。
'アイコンの絵のみを変えるには、その絵の番号が必要ですが、
'その絵の番号については http://officetanaka.net/excel/vba/tips/tips83.htm を
'ご参考にしてください。
'また、以下の例の「myBar.Controls(8)」の部分の「8」の値は、
'ボタンの数を数えて、絵を変えたいボタンが8個目にあったら「8」にします。
'これは事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して
'現状のボタンの中をチェックしておいてもOKです。
'操作したいツールバーの名前、もしくはインデックス番号は、
'BarName_n_Index_Check01()プロシージャなどで
'あらかじめチェックしておきます。
'################################################################################

Sub CmdBtnOnlyIcnChange01()

    Dim myBar As CommandBar         '操作対象のツールバーを代入するオブジェクト変数
    Dim myBarName As String         'ツールバーの名前を代入するための変数
    
    myBarName = "ツールバー01"      '操作したいツールバーの指定。ここでは「ツールバー01」を指定しています。
    
    
    '操作対象のツールバーをオブジェクト変数に代入します。
    'ここでの例では、「ツールバー01」を代入（＝操作可能状態に）します。
    Set myBar = CommandBars(myBarName)
    
    '8個めのボタンのアイコンの絵を変える。（ボタンの新規登録時にこのコードを一緒に書いて実行してもOKです。
    myBar.Controls(8).FaceId = 4       'http://officetanaka.net/excel/vba/tips/tips83.htm での、プリンタの絵にする。
    
End Sub

※イミディエイトウィンドウで
Commandbars("ツールバー名").Controls(変えたいボタンの番号).FaceID = 変えたい絵の番号
とやってもOKです。
（例：Commandbars("ツールバー01").Controls(8).FaceID = 4）
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

'################################################################

'すべてのツールバーの名前とインデックス番号のチェック

'###############################################################

Sub BarName_n_Index_Check01()

Dim ObjBar As CommandBar

For Each ObjBar In CommandBars

Debug.Print ObjBar.Name & "------" & ObjBar.Index

Next ObjBar

End Sub

'################################################################

'「ツールバー01」の削除。

'削除したいツールバーの名前、もしくはインデックス番号は、

'BarName_n_Index_Check01()プロシージャなどで

'あらかじめチェックしておきます。

'################################################################

Sub bardel() 'ツールバー01 の削除

Dim myBar As CommandBar 'おい、パソコンよ、ツールバーを代入するためのオブジェクト変数をメモリ上に作っとけ。

'操作したいツールバーを、オブジェクト変数に代入して操作可能にします。

'＝ここでは操作したいツールバーを、「ツールバー02」に指定して操作可能にします。

'おい、パソコンよ、「ツールバー02」という名前のツールバーを、オブジェクト変数のmyBarに代入しろ。

Set myBar = CommandBars("ツールバー02")

'指定したツールバーの削除

'おい、パソコンよ、オブジェクト変数に代入したツールバーを削除しろ。

myBar.Delete

End Sub

'################################################################################

'ツールバーへのボタンのみの新規登録

'自分が追加したツールバーの名前か番号が分かれば、

'そこへボタンのみを新規登録することもできます。

'以下の例の「myBar.Controls(8)」の部分の「8」の値は、

'ボタンの数を数えて、すでに7個のボタンがあったら「8」にします。

'同じ番号がかぶると、文言が表示されなかったりとおかしなことになるようです。

'事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して

'現状のボタンの中をチェックしておいてもOKです。

'操作したいツールバーの名前、もしくはインデックス番号は、

'BarName_n_Index_Check01()プロシージャなどで

'あらかじめチェックしておきます。

'################################################################################

Sub CmdBtnOnlyAdd()

Dim myBar As CommandBar '操作対象のツールバーを代入するオブジェクト変数

Dim myBarName As String 'ツールバーの名前を代入するための変数

myBarName = "ツールバー01" '操作したいツールバーの指定。ここでは「ツールバー01」を指定しています。

'操作対象のツールバーをオブジェクト変数に代入します。

'ここでの例では、「ツールバー01」を代入（＝操作可能状態に）します。

Set myBar = CommandBars(myBarName)

myBar.Controls.Add ID:=19 '新規ボタンとして「コピー」を追加します

myBar.Controls(8).Style = msoButtonIconAndCaption ' ボタンの表示形式を「イメージとテキスト」にする。

End Sub

'################################################################################

'ツールバーへのボタンのみの削除

'自分が追加したツールバーの名前か番号が分かれば、

'そこへボタンのみを新規登録することもできます。

'以下の例の「myBar.Controls(8)」の部分の「8」の値は、

'ボタンの数を数えて、消したいボタンが8個目にあったらその番号を書きます。

'事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して

'現状のボタンの中をチェックしておいてもOKです。

'操作したいツールバーの名前、もしくはインデックス番号は、

'BarName_n_Index_Check01()プロシージャなどで

'あらかじめチェックしておきます。

'################################################################################

Sub CmdBtnOnlyDel()

Dim myBar As CommandBar

Dim myBarName As String

myBarName = "ツールバー01"

Set myBar = CommandBars(myBarName)

myBar.Controls(8).Delete ' 番号が「8」のボタンを削除。

End Sub

'#############################################################################

'ツールバーの中の、ボタンのキャプション（文言）とインデックス番号のチェック

'操作したいツールバーの名前、もしくはインデックス番号は、

'BarName_n_Index_Check01()プロシージャなどで

'あらかじめチェックしておきます。

'#############################################################################

Sub BtnName_n_Index_Check01()

Dim ObjBar As CommandBar

Dim ObjBtn As Object '「CommandBarBottun」にしてしまうと、階層ボタンのところでエラーになるのでObjectのままにしておきます。階層ボタンは「CommandBarPopup」になるようです。

Dim StrBarName As String

StrBarName = "ツールバー01"

Set ObjBar = CommandBars(StrBarName)

For Each ObjBtn In ObjBar.Controls

Debug.Print ObjBtn.Caption & "------" & ObjBtn.Index

Next ObjBtn

End Sub

'################################################################################

'ツールバーへのボタンのアイコンの絵のみを変える。

'アイコンの絵のみを変えるには、その絵の番号が必要ですが、

'その絵の番号については http://officetanaka.net/excel/vba/tips/tips83.htm を

'ご参考にしてください。

'また、以下の例の「myBar.Controls(8)」の部分の「8」の値は、

'ボタンの数を数えて、絵を変えたいボタンが8個目にあったら「8」にします。

'これは事前に、後述の BtnName_n_Index_Check01()プロシージャなどを実行して

'現状のボタンの中をチェックしておいてもOKです。

'操作したいツールバーの名前、もしくはインデックス番号は、

'BarName_n_Index_Check01()プロシージャなどで

'あらかじめチェックしておきます。

'################################################################################

Sub CmdBtnOnlyIcnChange01()

Dim myBar As CommandBar '操作対象のツールバーを代入するオブジェクト変数

Dim myBarName As String 'ツールバーの名前を代入するための変数

myBarName = "ツールバー01" '操作したいツールバーの指定。ここでは「ツールバー01」を指定しています。

'操作対象のツールバーをオブジェクト変数に代入します。

'ここでの例では、「ツールバー01」を代入（＝操作可能状態に）します。

Set myBar = CommandBars(myBarName)

'8個めのボタンのアイコンの絵を変える。（ボタンの新規登録時にこのコードを一緒に書いて実行してもOKです。

myBar.Controls(8).FaceId = 4 'http://officetanaka.net/excel/vba/tips/tips83.htm での、プリンタの絵にする。

End Sub

※イミディエイトウィンドウで

Commandbars("ツールバー名").Controls(変えたいボタンの番号).FaceID = 変えたい絵の番号

とやってもOKです。

（例：Commandbars("ツールバー01").Controls(8).FaceID = 4）

　　
　　
※関連記事
Excel2010のリボンに、Excel2000と同じプログラムコードのコピペでユーザー設定ボタンを生成する。（一応ツールバー単位で）
https://euc-access-excel-db.com/tips/ct08_exceltruebasic/ct080860_vba_basic/tool-bar-auto-make-excel

Word2010のリボンに、Word2000と同じプログラムコードのコピペでユーザー設定ボタンを生成する。（一応ツールバー単位で）
https://euc-access-excel-db.com/tips/ct08_exceltruebasic/ct080860_vba_basic/tool-bar-auto-make-word

投稿タグ: ExcelVBA, Excelの独学, Excel連携VBA, パソコンでの自動化, ビジネスパソコンの基礎, リボンのカスタマイズ, 自動化

MENU

関連記事

最近の投稿

カテゴリー

MENU

Excel2010のリボンに、Excel2000と同じプログラムコードのコピペでユーザー設定ボタンを生成する～02。（一応ツールバー単位で。ピボットテーブル一発作成ボタン等も追加。ドロップダウンでの階層化ボタンも追加。）

関連記事

最近の投稿

カテゴリー

タグ