● Excel 2007 ～ 2019 対応マクロの勉強室 ●

※　注　意　事　項　※
コマンド・プログラム等を　コピペ　する時には、全角のスペース　が、
入っていることがありますので 半角に変換 してから、使用してください。

スマホ対策の為、長いコマンド・プログラム等を継続記号( linux は、"\" 、EXCELマクロは、"_" )で
故意に数行に分割している箇所が有ります。

下記写真は、Excel2010(上)と Excel2019(下)で同時に３個のブックをマクロで順番に開き整列表示 させた時の画面表示です。
Excel2010 の場合は、一つの Excel として( メニューコマンドが一個( 赤丸 )しかない )、 Excel2019 の場合は、まったく独立した Excel ブックとして( メニューコマンドが個別( 赤丸 )にある ) 表示されているのが、わかると思います。
この事が、マクロ作成時にこれから紹介する特別の配慮や工夫するが必要になりました。

特 別 の 配 慮 や 工 夫 ( 対 策 方 法 )

特殊なマクロのプログラムで対策する方法があるようですが、私は、あえて使用方法で解決する方法を取りました。

1. PC のディスプレイを追加して、マルチディスプレイの環境下で、使用する。
マルチディスプレイにすると同時にすべてのブックを表示することが出来るので、ユーザーフォームも隠れることなく作業が出来るようになります。

2. 私の様に予算のない方は、同時に開いているブックを[ 表示 ]のタブの[ 整列 ]機能で表示 方法を左右に分割して表示して作業をします。

この時、ユーザーフォームの表示は、作業対象のブックから表示する様にしてください。当然ですがマ クロ自身は、バックグラウンドで動く様 作成してください。

更に、ユーザーフォームのプロパティ[ StartUpPosition ]の設定を[ 1 - オーナーフォームの中央 ] に変更してください。 ユーザフォームが、隠れた時、適当なブックの[ メニューコマンド ]から、ユ ーザフォーム表示の指示をすると、ユーザフォームを開いたブックの中央に表示されるようになります。

マクロ作成時、気を付けることは、ある処理をさせる時に、この処理は、どのブックを対象としている かを明確にし処理の前に、対象ブックをユーザーフォームから、指定する際、今までは、変数にブック 名・シート名を保存していましたが、あえてマクロの表紙に保存し、そのブックを処理する時 には、マクロの表紙に保存してあるブック名・シート名を使用してアクティブにします。

3.３個のブックを同時に開き、ユーザーフォームのボタンクリックで正しくクリックしたブッ クを認識するか試しみました。

その方法は、

(1). 下記写真に示すように、ブック名 TEST_BOOK から、ユーザーフォームを表示さる。
(2). ブック名 TEST_BOOK のセル(1,1)をクリックして、ユーザーフォームのボタン［ボタンA］をクリックする。
(3). ブック名 BOOK1 のセル(2,3)をクリックして、ユーザーフォームのボタン［ボタンB］をクリックする。
(4). ブック名 BOOK2 のセル(3,4)をクリックして、ユーザーフォームのボタン［ボタンC］をクリックする。

認識した結果は、各ボタンをクリックした時点のブック名・クリックしたセル位置情報をブック名 TEST_BOOK のセル位置 ５ ～ ７ 行に書き込むようにしてあります。
結果は、下記写真のブック名 TEST_BOOK に書き込まれた値で、正しく認識することが、確認できました。
BOOK1・BOOK2 から、ユーザーフォームを開き同様に行っても同じ結果になりました。

[ マクロの表紙 ]については、[ 仕事に役立つExcelマクロの作り方 ]とそのページ内の
[ 2. マクロをバックグラウンドで動く様にする方法 ]で解説しています。

4. ブックを閉じる順序で、［ アドイン ］の［ メニューバー ］が、残ってします現象の対策。

複数のブックを開く順序は、一般的には、マクロのブックが、最初で次に編集等するブックを開く と思います。
この時、同時に開いたブックにも、［ アドイン ］の［ メニューバー ］が、追加されます。
( マクロのブックを開く前に、開いたブックには、［ メニューバー ］の追加は、ありません。)


作業が終了し、ブックを閉じるわけですが、普通は、順不同で、閉じると思います。 この時、マク ロブックを他のブックが残った状態で閉じると、［ アドイン ］の［ メニューバー ］が、残ってします現象が、発生してしまいます。

対策方法として、手動で閉じるときには、マクロブックを最後に閉じるように操作します。

マクロのプログラム側での対策方法として、私は、［ アドイン ］の［ メニューバー ］を表示す る前に、一度［ メニューバー ］リセットのステートメント( CommandBars("Worksheet Menu Bar") .Reset )を追加して対策をしています。 この方法だと、例え［ メニューバー ］に［ メニューコ マンド ］が残ったとしても、一度リセットしてから、表示するので問題は、なくなります。
また、マクロでブックを閉じるときには、マクロのブックを最後に閉じるようにする必要があります。

マクロでブックを閉じての終了プログラム例 ( 保存しての終了では、警告メッセージのオフをして おきます。)

 Application.DisplayAlerts = False   ' 警告メッセージをオフにする

 Workbooks("ブック名_A").Save          ' 上書き保存
 Workbooks("ブック名_A").Close         ' ブック名_A を閉じる
 Workbooks("マクロのブック名").Save  ' マクロブックを保存する時
 Application.Quit                    ' マクロブック・Excel の終了

 Application.DisplayAlerts = True    ' 警告メッセージをオフ解除する

5. マクロで別ブックをアクティブにしてもアクティブならない時の対策。

ユーザーフォームのボタンクリックで別ブックをアクティブにするには、Workbooks("〇〇〇〇. xlsx").Activateとしますが、何かの加減でアクティブならない時がありました。

この現象は、Excel 2019 になってから私は、気付きました。 それはユーザーフォームのボタンク リックで別ブックをアクティブし、そのブックのセル値を読み込ませてもユーザーフォームを表示し たブックのセル値を読み込むという事が起きたからです。
この現象は、テストマクロを作成、再現もできました。 原因は、不明です。？？

対策としては、フォーカス( アクティブ状態 )をブックに移す処理ステートメントを、下記の
様に一行追加するだけで済みました。 正しく動作するかの確認は、私が使用しているマクロで
確認しました。 追加する位置は、処理の先頭にしても同じ結果が得られました。

  Workbooks("〇〇〇〇.xlsx").Activate 

  '  ユーザーフォームから、フォーカス( アクティブ状態 )を
  '  ブックに移す処理

  VBA.AppActivate Excel.Application.Caption

このステートメントは、アクティブにしたブックを最前面に表示したいときにも有効です。

上記とは、別の方法でも、解決できることがわかりました。それは、ユーザーフォームを表示した 時のブック名を保存( 保存方法は、Private Sub UserForm_Initialize() を実行した時に、ブック 名を保存します。)しておき、ボタンクリック時の処理の先頭で、保存したブック名でユーザーフォ ームを表示した時のブックを一時的にアクティブにしても、解決できました。

6. 複数ブック使用時の Hide ( ユーザーフォームの非表示 )を使用するときの注意。

あるブックでユーザーフォームを表示して、〇〇〇〇.Hide でユーザーフォームを非表示に次に別 ブックから、非表示にしてあるユーザーフォームを開くと、ブックのアクティブは、当初ユーザー フォームを開いたブックへ移行し、ブックが切り替わってしまいます。

対策としては、Hide を使用せず、Unload でユーザーフォームをしっかりと消去することです。

〇 これらの配慮や工夫は、私のスキル内で思いつき工夫した事・経験した事です。もっと良い方法が あれば教えていただければ幸いです。 また、良い方法が、見つかりましたら追加していきます。

( 3項 [ 写真貼付マクロ ] [ 写真読込マクロ ] のダウンロード版で紹介 )

写真の挿入貼付でリンク貼付になるのを修正しました。( 先人の知恵を借用しました。)
今までの方法で写真を挿入(貼付)をして、別の PC や ホルダーに保存してから、そのブックを開く と写真が有 るべき所に下記の様な表示になってビックリします。
「 リンクされたイメージが表示できません。……………　」

      貼付のマクロは、下記の様に記述します。

      修正前   ActiveSheet.Pictures.Insert(myFname).Select
               ( myFname : 貼付写真のパス )
      修正後

     Set objShape = ActiveSheet.Shapes.AddPicture( _
           Filename:=myFname, _
           LinkToFile:=False, _
           SaveWithDocument:=True, _
           Left:=Selection.Left, _
           Top:=Selection.Top, _
           width:=Tate,
           height:=Yoko)

AddPicture の使い方の詳細は、下記で解説しています。

(1) AddPicture を使用した写真の貼り付け
    ( 写真の 90度回転は、省略しました。)

  ' 写真を貼付けるセルをアクティブ( 選択 )して、貼付け場所の
   縦・横位置、高さ・横幅を取得します。

    ActiveSheet.Cells(X, Y).Select　<--- X, Y は、写真を貼り付ける
                                          セルの位置データです。
    '
    With Selection
        yoko = .Left      <--- 挿入する写真の左端位置を取得
        tate = .Top       <--- 挿入する写真の上端位置を取得
        Wyoko = .Width    <--- 挿入する写真の横幅を取得
        Wtate = .Height   <--- 挿入する写真の高さを取得
    End With
    '
    ダイアログボックスを表示して貼り付ける写真を選択させると供に
    指定写真のフルパスデータを取得する。

    myFname = Application.GetOpenFilename _
                      ("写真ファイル(*.JPG;*.JPEG),*.JPG;*.JPEG")

    他の画像ファイルにも対応させたい時には、
    ("写真ファイル(*.JPG;*.JPEG;*.BMP;*.GIF;*.WMF)
                                ,*.JPG;*.JPEG;*.BMP;*.GIF;*.WMF")

  '----------------------------------------------------------------
  '  写真を貼り付け
  '  Shapes.AddPictureメソッドの引数は全て設定しないと動作しません。
  '  注意してください。
  '----------------------------------------------------------------
    同一写真について処理するので With ～ End with でくくる。

With ActiveSheet.Shapes.AddPicture( _
　　挿入する写真ファイル名をパス付きで指定
　　filename:=myFname, _　
　　False で独立した写真としての指定 True で元のファイルとのリンクを設定
　　LinkToFile:=False, _　
　　rue で Excelファイルと共に保存 False でリンク情報だけを保存
　　SaveWithDocument:=True, _
　　Left:=yoko, _　　 <--- 挿入する写真の左端位置を指定
　　Top:=tate, _　　　<--- 挿入する写真の上端位置を指定
　　この引数は省略できません。　いったん適当な値（ここでは0ポイント）
　　Width:=0, _　
　この引数は省略できません。 いったん適当な値（ここでは0ポイント）
　元写真の大きさがバラバラなので一旦、 張付けた写真に対して元写真と同じ高さ・幅に戻した後に所定のサイズに変更する。
　　Height:=0)
　　.ScaleHeight 1, msoTrue　<--- 元写真と同じ高さに戻す
　　.ScaleWidth 1, msoTrue 　<--- 元写真と同じ幅に戻しす

    '------------------------------------------------------------
    ' 写真を所定のサイズに変更する
    '------------------------------------------------------------
    ' 写真のサイズ取得する。
    
    x2 = .Width
    y2 = .Height

　　'　写真の拡大/縮小率を計算してサイズを変更する。

    .ScaleWidth (Wyoko / x2), msoTrue
    .ScaleHeight (Wtate / y2), msoTrue

    ' 張付けた写真の上に文字・線等が書けるように、写真の表示順序を
    ' 最背面にします。

    .ZOrder msoSendToBack

    End With

(2) AddPicture を使用した写真の貼り付け ( 上記マクロを簡素化してみました。 )

　　objShape を図形のオブジェクト名にする。
        Dim objShape As Shape
                ( 省略 )

   貼付け場所のセルをマウスでアクティブにするか、下記の様にプログラムで
　 アクティブにします。

　 X, Y は、写真を貼り付けるセルの位置データです。
   ActiveSheet.Cells(X, Y).Select

　 ダイアログボックスを表示して貼り付ける写真を選択させると供に指定写真のフルパスデータを取得する。

   myFname = Application.GetOpenFilename _
             ("写真ファイル(*.JPG;*.JPEG),*.JPG;*.JPEG")

  Set objShape = ActiveSheet.Shapes.AddPicture( _
    filename:=myFname, _         <--- 挿入する写真ファイル名を
                                            　　　 パス付きで指定
    LinkToFile:=False, _        <--- False で独立した写真と
                                            　　   しての指定
    SaveWithDocument:=True, _    <--- True で Excelファイルと
                                             　　  共に保存
    Left:=Selection.Left, _     <--- アクティブセルの
                                         　 　     左端位置を指定
                ( アクティブなセルの [ X 座標 ] 横位置座標 )
    Top:=Selection.Top, _    　  <--- アクティブセルの
                                        　  　  　上端位置を指定
                ( アクティブなセルの [ Y 座標 ] 縦位置座標 )
    Width:=Selection.width, _    <--- アクティブセルの横幅を指定
    Height:=Selection.height)    <--- アクティブセルの高さを指定

※※ おまけの情報 ※※

① 写真に名前を付けて、貼り付け後に処理し易くする。

    Dim objShape As Shape  　　 <--- objShape を図形の
                                           オブジェクト名にする。
            ( 省略 )

     objShape.Name = "○○○○"  <--- Picture1 とかの名前を付ける。

     参照の仕方(一例)

     With ActiveSheet.Shapes("Picture1")
　　LockAspectRatio プロパティに Falseを指定すると図形の縦横比を
　　自由変更にする事が出来ます。 msoTrue で 図形の縦横比を固定する。
　　     .LockAspectRatio = msoFalse 
　　     .Width = 150: .Height = 200   <--- 横・縦の幅を変更する。 
      End With 

② 写真を 90°回転する時の貼付け座標値の補正計算

写真を 90°回転して貼付ける時の下記のことを考慮する必要があります。

・写真の回転は、写真のセンターを基準にして回転すること。
・貼付け時の写真のサイズは、後に 90°回転するので幅・高さが当然逆にしておく必要がある。
・貼付けは、貼付け後 90°回転( 時計回り )した時に指定セルに貼付くよう貼付け位置の補正が必要。
・貼付け時、貼付け座標値がマイナス( Excel シート上からのはみ出し )になるとその分は移動し ないので 考慮が必要。( はみ出した時には、張付け位置がずれます。)

よって貼付け座標位置は、下記の様になります。( 下の説明図を参照してください。)

左位置 ( Left )は、 (アクティブセルの左位置座標位置 ) - {(高さ / ２) - (幅 / ２)}
上端位置( Top ) は、 (アクティブセルの上端位置座標位置) + {(高さ / ２) - (幅 / ２)}

マクロの記述は、下記の様になります。

     Dim objShape As Shape  　　 <--- objShape を図形の
                                        オブジェクト名にする。
           ( 省略 )

     myFname = Application.GetOpenFilename( _
                        "写真ファイル(*.JPG;*.JPEG),*.JPG;*.JPEG")

     With Selection
          yoko = .Width      　<--- アクティブセルの横幅を取得
          tate = .Height       <--- アクティブセルの高さを取得
     End With

    '---------------  90°回転する時の処理-----------------------
    Set objShape = ActiveSheet.Shapes.AddPicture( _
    	Filename:=myFname, _
    	LinkToFile:=False, _
    	SaveWithDocument:=True, _
    	Left:=Selection.Left - Tate / 2 + Yoko / 2, _
        Top:=Selection.Top  + Tate / 2 - Yoko / 2, _
        Width:= yoko, _
        Height:=tate)

       objShape.Rotation = 90　　<--- 時計回りの方向に
                                           90°回転します。

(3) 貼付け写真を変更( サイズ変更・削除等 )出来ないように固定する方法

方法は、写真を張付けたセルにセルロックをかけるだけです。
下記は、そのプログラム例です。

  Sub ○○○○()
      Dim Abc As Single
      ' いきなり実行するのではなく、確認をしてから実行します。
      Abc = MsgBox("このページの写真変更禁止を設定します。 _
                                    ", vbYesNo, "写真変更禁止確認")
      If Abc = vbNo Then Exit Sub 　　 <--- Noの時終了

      '---------------------------------------------------------

      ActiveSheet.Unprotect     <--- 一度シート保護を解除します。

      Cells.Select              <--- シート全体を選択します。
      Selection.Locked = False　<--- シート全体のセルの保護ロック
                                          　　　　  フラグをOFFする
      ' セル範囲("B2:G42")を保護する。
      Range("B2:G42").Select    　<--- 写真を張付けたセル範囲を選択
                                                   　     します。
      Selection.Locked = True 　　<--- 選択されたのセルの保護ロック
                                      　　　        フラグをONする
      ActiveSheet.Protect userinterfaceonly:=True　 <--- マクロからの
                                         　　　　　書換は、可能にする

      Range("A1").Select
      MsgBox ("写真変更禁止完了") 　 <--- 終了メッセージ
  End Sub

上記の写真張付け方法で作成した、「写真張付マクロ」と写真一覧表を 作成する「写真読込マクロ」を公開しています。
　　　　　　　　下記からダウンロードしてください。

○ ポイント　1　　( 3項 [ 写真貼付マクロ ] のダウンロード版で紹介 )
　2007・2010に、なってから、ブックの拡張子が、○○○○.xlsと○○○○.xlsxが、あるため保 存の際は、区別し指定しなければならなくなった。
　( 単に上書き保存の時には、Workbooks(ブック名).Save でＯＫです。 )

　下記のように、記述してします。

  ' Dpath 格納先のパス Fname ブック名
  AAA = Dpath & "\" & Fname & ".xlsx"

  ○○○○.xlsxだけを使用するのであれば、下記の処理は、不要です。

  '-------------------------------------------------------------
  ' Excel 2007・2010 対策 書込み時に、拡張子の指定がいる。
  '                                51=*.xlsxモードで保存
  '-------------------------------------------------------------
  ActiveWorkbook.SaveAs Filename:=AAA, FileFormat:=51
  ' ActiveWorkbook.SaveAs AAA      <--- Excel2003では、
                                      これだけで済んでいました。
○  ポイント 2 
  Excel2002・2003等の拡張子( ○○○○.xls )で保存する方法。

  '--------------------------------------------------------------
  '      ここは、参考資料です。
  '      Excel ブックのファイルフォーマットコード
  '43 = xlExcel9795
  '51 = xlOpenXMLWorkbook (without macro's in 2007, xlsx)
  '52 = xlOpenXMLWorkbookMacroEnabled 
  '     (with or without macro 's in 2007, xlsm)
  '50 = xlExcel12 (Excel Binary Workbook in 2007 with or without
  '                                                macro 's, xlsb)
  '56 = xlExcel8 (97-2003 format in Excel 2007, xls)
  '      Excelのバージョンコード
  '      Code=Val(Application.Version) で調べられます｡
  ' 9: sv = "2000"
  '10: sv = "2002"
  '11: sv = "2003"
  '12: sv = "2007"
  '14: sv = "2010"
  '15: sv = "2013"
  '16: sv = "2016", "2019"
  '----------------------------------------------------------
  '  Excel2007でExcel2003等のファイルを
  '  旧バージョンのまま保存するときの処理
  '----------------------------------------------------------
  AAA = Dpath & "\" & Fname & ".xls"  <--- 拡張子を書込む
                                         　 バージョンに合わせる。
  Application.DisplayAlerts = False    　<--- 警告メッセージを
                                        　  停止する指定
  ' 56 :  Excel97-2003
  ActiveWorkbook.SaveAs Filename:=AAA, FileFormat:=56  
  Application.DisplayAlerts = True    <--- 警告メッセージを停止解除

○ 本ページで、解説した内容を盛り込んで作成したマクロを公開しています。

マクロの使い方は、ブックの表紙に記述しています。色々試して、マクロの動きを体験してみてください。
マクロを実行する 窓（フォーム）の表示は、[ アドイン ] を開いて、メニューコマンドを、クリックしてください。

マクロは、パスワード等一切掛けていませんので、マクロの勉強の材料にしてください。

下記マクロは、Excel2003等の互換モードで動作するようにしています。
ブックの書込み・セルの横方向の最大数も考慮させています。

[ お断り ]
① マクロは、私が理解した範囲で、作成していますので、他にもっと良い方法があると思いますが、 問題なく動作していますので、参考になると思います。
② 下記マクロは、作業するのExcelブックの裏で、マクロが、動くように作成しています。実行時 の、必要なデータは、マクロブックのシート名 「 表紙 」に書き込んでいますのでマクロブッ クのシート名「 表紙 」の設定値を変更しない様にしてください。
ex.
この EXCELマクロブックの名前
Public Const AAname As String = "シートの操作マクロ.xlsm"
ここの "表紙" は、変更しないこと。
Public Const BBname As String = "表紙"

マクロの表紙については、「 8. 仕事に役立つExcelマクロの作り方 」で説明しています。
変更するときには、結果がどうなるかを良く確認して下さい。
③ ブック名を変更するときには、module1 の先頭に記述している、ブック名も変更してください。
④ 解凍したマクロのブックは、コピーまたは移動してから、使用してください。
⑤ 一部のマクロブックを Excelブックオープン時に自動で「 アドイン 」バーを選択する様にしました。

すぐ使えるExcel2010・2019対応マクロ
　　　　　　( H26.05.01 Excel 2010,2013 写真貼付の処理修正しました。)

1.[ 写真貼付マクロ ] は、A4版の工事写真帳の作成に使用します。

指定したセルに張付ける機能も追加しています。
H30.3 貼り付け方法を変更してアップデートしました。
H28.05.06 張付けた写真を変更できないようにロックをかける機能を追加しました。
2019.06.14 Excel 32bit, 64bit のマクロに対応するように改訂しました。

2.[ 写真読込マクロ ] は、A4用紙に28枚の写真を貼付けるマクロで写真のチェック等に使用します。

最大 12 ページ　336 枚 まで可能

2019.06.07 写真撮影日を書込む機能を追加してアップデートしました。

3.[ 簡易CADマクロ ] は、シート上に、簡単な図面を書きたい時 便利なマクロ。

使い方は、簡単ですので、色々試して使用ください。
H25.8.22 機能追加
任意角の直線を引けるように機能追加しました。
プログラムの解説は、マクロ内に細かく記載しました。

4.[ シート操作マクロ ] は、シートのコピー・連続削除・並び替え・印刷等 便利なマクロ。

使い方は、簡単ですので、色々試して使用ください。
請求書・内訳書・計算書等のシート内に関数等の計算式を書込んでいるシートを計算式なしにして、別シートまたは、別ブックへコピーする機能もあります。
もちろん、セルの幅・高さも元の様にコピーします。
H25.06.12 「計算式を取ってのコピー」を改良しました。

5.[ セル操作マクロ ] は、セルの文字列の操作( 置換・削除・数値-->文字列・文字列-->数値)

セルが書き換えられないように保護する・計算式がどのセルに有るかを色分けする等 便利なマクロ。
セル範囲 AAA(703) ～ XFD(16384) に対応させたマクロをダウンロードできるようにしました。
H26.02.25 機能追加
ドラックした範囲のセルの幅・高さを mm 単位で設定できる機能を追加。

6.[ 印刷マクロ ] は、指定されたフォルダに保存されているExcelブックを抽出し、抽出リストを ドラッグして 印刷したいExcelブックを指定して、印刷をします。ブック名/シート名をフッターとして、印刷する機能もあります。

7.[ 給与計算マクロ( 見本 ) ] は、所得金額と扶養家族の人数から、税額表を検索して所得税を抽出する。

マクロの見本と小規模の事業所で、そのまま使用可能な給与計算マクロです。
給与計算マクロは、項目名を変更すれば、すぐにも使用できます。
令和 ４ 年度分源泉徴収税額対応版に改訂しました。

8.[ 検索住所マクロ ] は、郵便番号から、住所を表検索するマクロ( 見本 )を公開しています。

9.[ 自動処理シートマクロ ] は、連続したシートへの自動処理のサンプルマクロを公開しています。

テスト用に、白紙のブック( シート数 17 )とシートへの書込みマクロを組み込み済。
プログラムには、コメントを各所に入れ、解説しています。
自由に改造して使用してください。

10.[ 出勤台帳作成マクロ ]は、出勤台帳・日報等作成するマクロを公開しています。

詳細等は、「11. 出勤台帳・日報等作成時、マクロでの年月日の扱い方」で解説しています。

ダウンロードは、下記をクリックすると、別窓が、開きますので、その中でダウンロードして下さい。

ある企業で使用している締め日が自由に設定できる「 作業日報_作成マクロ 」も 同梱しました。
使い方等は、マクロ内の別ページで解説しています。

[注意事項] 　H24.11.10 追記
ダウンロードしたマクロは、解凍した後、別の保存場所へコピーまたは、移動してから使用してくだ
さい。 最初にマクロを開くと警告文がシートの上の方に表示されます。
警告の解除は、マクロ(Excel ファイル)を開く前に行ってください。

※　警告の解除方法　※

この操作は、マクロを開く前に行ってください。
ダウンロードしたマクロを、解凍した後、別の保存場所へコピーまたは、移動します。
そして、そのマクロのファイルを右クリックから、［プロパティ］を開き 右の写真の様に セキュリティ の表示があったら、赤丸個所［許可する(K)］にチェックを入れて［適用(A)］---> ［OK］をクリックします。

○ 一つ目は、ダウンロードしたマクロの危険性の警告です。 これは、[編集を有効にする(E)]をクリックしてください。

○ 二つ目は、Exccel のセキュリティの警告文です。　 これは、[コンテンツを有効化]をクリックしてください。
以上の二つを有効にしないとマクロは、動作しません。一度有効化すれば、次からは、普通に普通に起動します。

○ すべてのマクロは、細かなエラー処理をしていませんので、正しい設定をしないと、エラーになり、マクロの処理が停止しますので承知ください。

ダウロードできる Excel マクロのプログラムは、すべてマクロプログラムを公開しています。
また、ウィルスチェックは、ソーネクストのスーパーセキュリィティZEROでチェックをしていますので、セキュリティ等の問題は、ないと思います。

○ 上記 ３項で、ダウロードできるマクロに関して、解説ページを作りました。

○ ポイント ( 3項 [ 写真張付マクロ ] のダウンロード版で紹介 ) マクロでシートをコピーさせたときに、共有ファイルでエラーが出ることがあります。

このエラーは、BUFFALO 等のファイルサーバを使用している時に、出ると思います。
この様な場合には、該当ファイル・マクロを自分自身のパソコンにコピーしてから、作業をし、 終了したらサーバにファイルを戻してやるという方法が良いと思います。

この時には、該当ブックの共有を解除してやれば、シートコピーが出来るようになります。
Excel2007から、共有ファイルの変更は、チェックが入るようになった様です。？？？
下記の様に、シートコピーをする箇所の前に記述します。

 '------------------------------------------------------------------
 '       Excel 2007・2010 対策
 ' ブックの共有解除をしないとシートコピーできない。
 Application.DisplayAlerts = False <-- 警告メッセージを停止する指定
 If ActiveWorkbook.MultiUserEditing Then _
                               ActiveWorkbook.ExclusiveAccess
 Application.DisplayAlerts = True　<-- 警告メッセージを停止する解除
 '------------------------------------------------------------------
 '    シート名に枝番を付けてコピーするサブルーチン( 例 )
 '    ここでコピーしたいシートをアクティブにしておきます。
      Worksheets(○○○○).Activate     <---- ○○○○はシート名
      シートコピー
 '
    ( 途中処理省略 )
 '
 Sub シートコピー()
   '
     Fname = ActiveSheet.Name   <--- シート名の取得する
     SS = Len(Fname)            <--- シート名の文字数を取得する
     ' 関数 InStr でシート名に枝番( -n )があるかをチェックする。
     N = InStr(1, Fname, "-")
     S1 = SS - N + 1            　　　<--- 枝番の文字を計算する
     If N <> 0 Then
         BBB = Left(Fname, SS - S1)  <--- 枝番を取ったのシート名を
         '                          　　　　　　     を取得する
         HH = Right(Fname, SS - N)  <--- 枝番だけの文字列を取得する
         NN = Val(HH)               <--- 文字列を数値に変換する
         AAA = BBB & "-" & CStr(NN + 1) <--- 追加枝番のシート
     Else　　　　　　　　　　　　　　　　　　 名を作成する
         AAA = Fname & "-" & CStr(1)  <--- シートの数が、1 の時、
     End If                                   　　 枝番 -1 を作る
     '
     Application.DisplayAlerts = False  <--- 警告メッセージ表示を
     ' ここで、シートを後ろへ追加する。        停止する。
     mm = ActiveSheet.Name
     Sheets(mm).Copy After:=Sheets(mm)
     CCC = ActiveSheet.Name
     Worksheets(CCC).Name = AAA    <--- シート名の変更する
     Application.DisplayAlerts = True   <--- 警告メッセージ表示を
     '　　　　　　　　　　　　　　　　　　　有効にする。
  End Sub

○ 任意のセルの保護をする。( 3項 [ セル操作マクロ ] のダウンロード版で紹介 )

　1. 手作業では、下記の手順でします。
　　① シートの左上端をクリックして、セル全体を選択する。
　　② 適当なセルの上でマウスを右クリックし、[ セルの書式設定 ] --> [ 保護 ] を選び、ロック のチェックを OFF する。
　　③ 保護したいセル範囲をドラックし、マウスを右クリックし、[ セルの書式設定 ] --> [ 保護 ] を選び、ロックのチェックを ON する。
　④ [ ホーム ] --> [ 書式 ] --> [ シートの保護 ] --> [ OK ]

2. 1項をマクロで記述すると下記の様になります。

    ActiveSheet.Unprotect         <-- 一度シート全体の保護を解除
    Cells.Select                  <-- シート全体を選択
    一度すべてのセルの「保護のロックフラグ」を OFF する
    Selection.Locked = False 
　  保護するセルの範囲をアクティブにする
    Range("保護するセルの範囲").Select 
  ( 保護するセルの範囲が複数ある場合には、「,」を入れて定義します。
                                     ex."O3:T5,O8:P21,O24:U30")
    Selection.Locked = True>   <-- セル保護のロックフラグを ON する

    ' セル保護のロックフラグに従ってセルを保護する。
      但し、「マクロからの変更は可能」に設定する。
    ActiveSheet.Protect Contents:=True, userinterfaceonly:=True

3. 指定したセル以外のセルに、保護を掛ける。

    ActiveSheet.Unprotect
    Cells.Select
    一度すべてのセルの「保護のロックフラグ」を ON する
    Selection.Locked = True
    Range("保護するセルの範囲").Select
    Selection.Locked = False <-- セル保護のロックフラグを OFF する

    ActiveSheet.Protect Contents:=True, userinterfaceonly:=True

　　に、変更すると、選んだ範囲外に保護が掛かります。

○ シート全体の保護を解除する方法

    ActiveSheet.Unprotect       <-- シートの保護解除
    Cells.Select                <-- シート全体を選択
    Selection.Locked = False　  <-- セルのロックフラグを OFF する
    Range("A1").Select          <-- シート全体を選択状態を解除

○ ここでは、逆に保護のかかったセルを視覚的に確認(セルに色付け)出来るようにする方法

　1. 「 7. インプットボックスで、セル参照結果を取得する方法」の方法でチェックするセル範囲の 情報を取得します。

　2. セルに保護がかかっているかのチェックは、CL_Range は、チェックするセルのアドレスデータ。
CL_Range は、プログラムの先頭で Dim CL_Range As Variant で宣言して置く。
ここで、CL_Range にチェックするセルのアドレスを設定する。

     If CL_Range.Locked = True Then
           セルに保護がかかっている時の処理をする。
           ' セルに色を付ける
           Range(CL_Range).Select            <---- セルを選択
           With Selection.Interior
               .Pattern = xlSolid            <---- 塗りつぶし

     ' 参考 パレット番号( 色コード )
     '        1: 黒, 2: 白, 3: 赤, 4: 明るい緑, 5: 青
     '        6: 黄, 7: ピンク, 8: 水色, 9: 濃い赤
     '       10: 緑, 11: 濃い青, 12: 濃い黄, 13: 紫
     '       14: 青緑, 15: 25%灰色, 16: 50%灰色
     '       26: ピンク, 28: 水色, 33: スカイブルー
     '       43: ライム, 44: コールド, 46: オレンジ 

             .ColorIndex = 6  <---- 色指定 黄色(ColorIndex番号)
           End With    RGBコードでは、.Color = RGB(255, 255, 0)
     End If            と書きます。

※ 文字に色を付ける時は、下記の様に書きます。 ※

     ActiveSheet.Cells(y, x).Select  　 <-- 文字に色を付けるセル
                                 　　　　　          (y, x)を選択
     Selection.Font.ColorIndex = 3 　   <-- 文字の色 赤

パレット番号( 色コード ) ColorIndex 番号・10進コード・RGB コード 一覧表
　　　　　　　　　　( ColorIndex 番号は、1 ～ 56 の範囲です。 )

上記のコード 一覧表を作成するマクロの詳細は、下記をクリックしてみてください。
マクロの詳細を見るには、
　　　　　　【 コード 一覧表を作成するマクロの詳細 】をクリックしてください。

※ 参考情報 ※　    図形の色コード ColorIndex 番号・10進コード・RGB コード 一覧表
　　　　　　　　　　　　( ColorIndex 番号は、1 ～ 56 の範囲です。 )

上記の図形の色コード表の作成方法は、上記のマクロに記述してあります。

　3. 参考情報 パレット番号( 色コード )を使って文字に色を付ける方法

  '  文字に色を付ける
  ActiveSheet.Cells(y, x).Font.ColorIndex = ( 色コード )
   ( y: セルの縦位置 x: セルの横位置 )
  または、
  ActiveSheet.Cells(y, x).Select
  Selection.Font.ColorIndex = ( 色コード )

  Selection.Cells.Font.FontStyle = "標準"  <-- 文字の太さを標準に
  Selection.Cells.Font.FontStyle = "太字"  <-- 文字を太字に
  Selection.NumberFormatLocal = "@"        <-- セルを文字列に
  Selection.NumberFormatLocal = "0_ "      <-- セルを数値に

　4. 上記をプログラムとして作成した例です。
　　このプログラムは、 [ セル操作マクロ ] のダウンロード版で使用しています。

　　 AAname : マクロのブック名 BBname : マクロの表紙のシート名 です。
　　リストアップしたセルのアドレスは、「マクロの表紙」に書込んでいます。

 Dim CL_Range, C_Range As Variant  <-- Variant で宣言してください。

       ( 途中処理省略 )

 Sub ○○○○()    <-- フォームのボタン等をクリックしたら、
    '                   ここへジャンプさせる。
    ' 保護のかかったセルの抽出。
    Locked_Cell_get
 End Sub

       ( 途中処理省略 )

 Sub ××××()    <-- フォームのボタン等をクリックしたら、
    '                   ここへジャンプさせる。
    ' 色付けしたセルのいろを消す。
    Cell_Color_off
 End Sub

       ( 途中処理省略 )

保護のかかったセルをリストアップしてセルに色を付けるサブルーチン。

Sub Locked_Cell_get()

※ 補足 ※
　　 シート上の使用範囲を自動選択させるには、ActiveSheet.UsedRange.Select を実行します。

 ' ドラック範囲を取得
 ' サブルーチン[ Range_data ]は、「7. インプットボックスで、
 ' セル参照結果を取得する方法」で解説しています。

 Range_data AAA, BBB

 C_Range = AAA & ":" & BBB    <-- ドラック範囲のアドレス

 '-----------------------------------------------------------
 ' 「表紙」のリストデータ消去   データの個数を取得
 N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value 
 
※ 補足 ※

  リストデータのカウントは、シート「表紙」のセル(2,15)に
   関数 [=COUNTA(R[1]C:R[99998]C)+2]を書込み、
   カウントさせています。

  if N >2 then    <-- N = 2 の時は、データなし
     For i = 3 To N
         Workbooks(AAname).Sheets(BBname).Cells(i, 15).Value = ""
     Next i
  End If
  '-----------------------------------------------------------
  ' 保護のかかったセルをリストアップする。
  II = 3
  ' ドラックされたセル範囲をすべて検査する。
  For Each CL_Range In ActiveSheet.Range(C_Range)
      ' 保護なし: False,　保護有: True
      If CL_Range.Locked = True Then
        ' 保護のかかっているセル位置データをリストアップする。
        ' A1,AB10 というレンジデーとして取得するため、Address に 
        ' (False,False) を付けます。
        Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value = _
        CL_Range.Address(False,False)
        II = II + 1
      End If
  Next
  '-----------------------------------------------------------
  ' リストアップしたセルに色を付ける。
  N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value
  if N >2 then    <-- N = 2 の時は、データなし
    For II = 3 To N
      ' リストから、セル位置データを読み出す。
      CL_Range = \
       Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value
      Range(CL_Range).Select                    <-- セルを選択
      ' セルに色を付ける
      With Selection.Interior
          .Pattern = xlSolid                  <-- 塗りつぶし
          ' 参考 色コード 1: 黒, 2: 白, 3: 赤, 4: 明るい緑
          '               5: 青, 6: 黄, 7: ピンク, 8: 水色
          .ColorIndex = 6                      <-- 色指定 黄色
      End With
    Next II
  End If
End Sub

ドラッグした範囲の始まり位置・終わり位置を取得するサブルーチン。
Sub Range_data(AAA, BBB As Variant)
    Dim Hogo_range As Range   <-- 変数をレンジ型変数にする。
    Dim XXX As Variant        <-- 変数をバリアント型変数にする。
    'インプットボックスで範囲を選択させます。
    Set Hogo_range = _
        Application.InputBox(prompt:="範囲をドラッグ", Type:=8)
    '-------------------------------------
    '  Address(False, False)で
    '  A1参照形式のレンジデータが取得できます。
    CCC = Hogo_range.Address(False, False)
                                                    
    XXX = Split(CCC, ":") <-- レンジデータの区切り文字( : )で分割
                                 配列データとして XXX に代入します。
    AAA = XXX(0)          <-- ドラッグ範囲の始まり位置を取得します。
    BBB = XXX(1)          <-- ドラッグ範囲の終わり位置を取得します。
    '-------------------------------------
    '  変数 AAA と BBB にドラッグ範囲の始まりと終わり位置が
    '  A1参照形式のレンジデータとして取得できます。
End Sub

リストアップしたセルの色を消すサブルーチン。
Sub Cell_Color_off()
    ' リストアップしたセルの色を消す。  データの個数を取得
    N = Workbooks(AAname).Sheets(BBname).Cells(2, 15).Value
    if N >2 then    <---- N = 2 の時は、データなし
       For II = 3 To N
         ' リストから、セル位置データを読み出す。
         CL_Range = _
            Workbooks(AAname).Sheets(BBname).Cells(II, 15).Value
         Range(CL_Range).Select                   <--- セルを選択
         Selection.Interior.Pattern = xlNone    <--- 塗り
       Next II                                            つぶしなし
    End If
End Sub

　　　上記の写真張付け方法で作成した、「セル操作マクロ」を公開しています。
　　　下記からダウンロードしてください。

【 セル操作マクロをダウンロードする 】

○ インプットボックス( InputBox )で、セル参照 (Range オブジェクト)をするには、Typeを 8 にして行います。
( 3項 [ セル操作マクロ ] のダウンロード版で紹介 )

Set Hogorange = Application.InputBox(prompt:= _
　　　　　　　　　　　　　 "保護する範囲をドラッグしてください", Type:=8)

参考情報 1　　引数Typeに指定可能な値

　　　　　　値　　　説明
　　　　　　 0　　　数式
　　　　　　 1　　　数値
　　　　　　 2　　　文字列 (テキスト)
　　　　　　 4　　　論理値 (True または False)
　　　　　　 8　　　セル参照 (Range オブジェクト)

参考情報 2　MsgBox, InputBox のメッセージを改行して表示させる方法

　　　　　　　例として下記のようにするとメッセージが二行にわたって表示されます。
　　　　　　　( 表示例 下記写真 )

　　　　　　　Dim MSG As String
　　　　　　　vbNewLine を入れると改行できます。
　　　　　　　MSG = "1 行目のメッセージ" & vbNewLine & "2 行目のメッセージ"
　　　　　　　Bt = MsgBox(MSG, vbCritical + vbOKOnly, "警告")

　　　　　　　

(1) セルのアドレスを取得する(Addressプロパティ)を使用してセル参照範囲を取得する方法。

下記がプログラム例です。

  Sub H_Range(AAA, BBB As Variant)
     Dim Hogo_range As Range      <-- 変数をレンジ型変数にする。
     Dim XXX As Variant          　　 <---- 変数をバリアント型
     'インプットボックスで範囲を選択させます。      変数にする。
     Set Hogo_range = _
         Application.InputBox(prompt:="範囲をドラッグ", Type:=8)
     '-------------------------------------
   'ddress(False, False)でA1参照形式のレンジデータが取得できます。
     CCC = Hogo_range.Address(False, False) 
     XXX = Split(CCC, ":")    <-- レンジデータの区切り文字( : )で
                           分割配列データとして XXX に代入します。
     AAA = XXX(0)     <-- ドラッグ範囲の始まり位置を取得します。
     BBB = XXX(1)     <---ドラッグ範囲の終わり位置を取得します。
     '-------------------------------------

変数 AAA と BBB にドラッグ範囲の始まりと終わり位置がA1参照形式のレンジデータとして取得できます。

    End Sub

(2) 単純に計算式でセル参照範囲を取得する方法。

  Set Hogo_range = Application.InputBox(prompt:= _
        "保護する範囲をドラッグしてください", Type:=8)
   ' 再度ドラッグされた範囲を選択する。
   Hogo_range.Select
   ' RangeSelectionで選んだセル範囲の位置(番号)を取得します。
   With ActiveWindow.RangeSelection
        y1 = .Columns.Column
        y2 = .Columns(.Columns.Count).Column
        x1 = .Rows.Row
        x2 = .Rows(.Rows.Count).Row
   End With
   ' y1 の値から、A1参照形式 An ～ Zn , AAn ～ に変換する。
   ' セル位置 Z(26) の次は、AA(27)、AZ(52) の次は、BA(53)になる。
   ' この処理を、下記で行う。アルハベット A ～ Z が、26文字で
   ' あることに着目して処理をする。
   ' Chr(64 + y1)は、10進コードで文字に変換するマクロ。
   ' Chr(64 + 1) --> A
   ' Chr(64 + 2) --> B,・・・
   ' Chr(64 + 26) --> Z の文字になります。
   ' セル範囲の始まり

　計算式によって、y1 の値から、A1参照形式 An ～ Zn , AAn ～ に変換するプログラム。
　　　　　　　　　y1 : (横方向の開始セル位置(番号)) y2 : (横方向の終了セル位置(番号))

   M1 = Int(y1 / 26): M2 = y1 Mod 26
   If M2 = 0 Then M1 = M1 - 1: M2 = 26
    ' ドラック範囲の開始セル位置の算出
   If M1 = 0 Then
      '   セル位置、An ～ Zn の計算
      AAA = Chr(64 + M2) & x1 
   Else
      '   セル位置、A○n ～ Z○n の計算
      AAA = Chr(64 + M1) & Chr(64 + M2) & x1  
   End If
   ' ドラック範囲の終了セル位置(y2)の値から、A1参照形式を算出
   M3 = Int(y2 / 26): M4 = y2 Mod 26
   If M4 = 0 Then M3 = M3 - 1: M4 = 26
   If M3 = 0 Then
      '   セル位置、An ～ Zn の計算
      BBB = Chr(64 + M4) & x2 
   Else
      '   セル位置、A○n ～ Z○n の計算
      BBB = Chr(64 + M3) & Chr(64 + M4) & x2
   End If

変数 AAA と BBB にドラッグ範囲の始まりと終わり位置がA1参照形式のレンジデータとして取得 できます。

セル範囲を拡大したい方のため、AAA(703) ～ XFD(16384)に対応させるマクロの記述例を紹介して おきます。

下記は、セル範囲 A(1) ～ XFD(16384) まで対応させた計算式のマクロです
( セル XFD(16384)は、Excel2007・2010の最終セル位置です )
y1 : (横方向の開始セル位置(番号)) y2 : (横方向の終了セル位置(番号))

  AAA = "": BBB = ""
  '
  If (y1 - 702) < 0 Then    <-- A ～ ZZ(702) と
      '  A ～ ZZ の処理          AAA ～ XFD(16384) の範囲の判定
      M1 = Int(y1 / 26): M2 = y1 Mod 26
      If M2 = 0 Then M1 = M1 - 1: M2 = 26
      '
      If M1 = 0 Then
          AAA = Chr(64 + M2) & x1
      Else
          AAA = Chr(64 + M1) & Chr(64 + M2) & x1
      End If
      '
  Else
      ' AAA ～ XFD の処理
      M = y1 - 26   <-- A ～ Z の分を引く
      '  676は、AAからZZまでのセルの数
      '  ３桁のセル位置を①②③で表すと ①は、Chr(64 + M1)
      '  ②は、Chr(64 + M3)
      '  ③は、Chr(64 + M4) で A ～ Z の文字を作っています。

      M1 = Int(M / 676): M2 = M Mod 676 
            ' 
 ' 二桁目②が A の時、M3=0 になるので 26(A ～ Z = 26) を加算する。
 ' (M3=0時、Chr(64 + 1)つまり、A にするため)
 ' M ÷ 676 の余りが無いときは、Z にするため、M3 = 26 にする事と
 ' M1 の値が 1 多くなるため。

      M3 = Int((M2 + 26) / 26): If M2 = 0 Then M1 = M1 - 1: M3 = 26
      '
         AAA = Chr(64 + M1)
         M4 = M2 Mod 26: If M4 = 0 Then M4 = 26
         ' 個別に作った文字①②③を合成する。
         ' ドラッグ範囲の始まり位置を取得します。
         AAA = AAA && Chr(64 + M3) & Chr(64 + M4) & x1
      '
  End If

変数 AAA にドラッグ範囲の始まり位置がA1参照形式のレンジデータとして取得できます。

  '
  If (y2 - 702) < 0 Then
      ' A ～ ZZ の処理
      M3 = Int(y2 / 26): M4 = y2 Mod 26
      If M4 = 0 Then M3 = M3 - 1: M4 = 26
  '
      If M3 = 0 Then
          BBB = Chr(64 + M4) & x2
      Else
          BBB = Chr(64 + M3) & Chr(64 + M4) & x2
      End If
  '
  Else
      ' AAA ～ XFD の処理
      M = y2 - 26   <-- A ～ Z の分を引く
      '
      M1 = Int(M / 676): M2 = M Mod 676
      M3 = Int((M2 + 26) / 26)
      If M2 = 0 Then M1 = M1 - 1: M3 = 26
      '
         BBB = Chr(64 + M1)
         M4 = M2 Mod 26: If M4 = 0 Then M4 = 26
         ' ドラッグ範囲の終わり位置を取得します。
         BBB = BBB & Chr(64 + M3) & Chr(64 + M4) & x2
  End If

変数 BBB にドラッグ範囲の終わり位置がA1参照形式のレンジデータとして取得できます。

○ コピーと名前変更するときには、Windows Script Host Object Model を使用しているので、 [マクロ] - [ツール] - [参照設定]で上記のオブジェクトにチェックを入れて、使用すること。

　　写真データを指定フォルダへコピーし、名前を変更する見本のマクロを公開しています。
H27.06.14 機能変更しました。
　　○ 任意の拡張子に対応するようにしました。
　　　 下記からダウンロードしてください。

                  下記に、プログラム例を示します。

  '------------------------------------------------------
  '           書込み先のフォルダが有るかチェックする
  '           同一のファイル名がないかチェックする
  '------------------------------------------------------

「ネットワークドライブの参照」についてのは、「 8. 仕事に役立つExcelマクロの作り方 」で 詳しく解説しています。

  ' ネットワークドライブの参照
  Public Declare Function SetCurrentDirectory _
            Lib "kernel32" Alias "SetCurrentDirectoryA" _
                            (ByVal lpPathName As String) As Long
       ( 省略 )
  '  Fname2=( 書込み先のフォルダのパス )
  '  CCC=( コピーするファイル名 )
  '
  Fname3 = Fname2 & CCC & ".jpg"
  '
  With New IWshRuntimeLibrary.FileSystemObject
  '
  '   Fname2=( 書込み先のフォルダのパス )
  '   BBB=( 読込先のフォルダのパス )
  '
  '    書込み先のフォルダが有るかチェックする
  '
   If Not .FolderExists(Fname2) Then
      vbExclamation    <-- 注意メッセージアイコンを表示させます。
   MsgBox "コピー先のフォルダ" & BBB & "が見つかりません。", _
              vbExclamation
　    GoTo ( エラーの時の処理へ、ジャンプ )
　 End If
  '
  '            同一のファイル名がないかチェックする
  '
     If Not .FileExists(Fname3) Then
　　　　a = a    <---- デバック用のブレーキングポイントのダミー
　　 Else
	MsgBox "同一ファィル「 " & CCC & " 」があります。", _
               vbExclamation
	GoTo ( エラーの時の処理へ、ジャンプ )
　　 End If
  '
  End With
  '------------------------------------------------------
  '                  指定フォルダへ、書き込む
  '------------------------------------------------------
  With New IWshRuntimeLibrary.FileSystemObject
  '
  ' Fname1=( 読込側のパス + ファイル名 )
  ' Fname2=( 書込み先のフォルダのパス )
  '
        .CopyFile Fname1, Fname2, True
  '
  End With
  '------------------------------------------------------
  '                   名前変更
  '------------------------------------------------------
  ' 書込み側のパス設定
  ADir = ( 書込み側のパス )
  ' カレントディレクトリの設定
  If ADir <> "" Then

    If Left(ADir, 2) = "\\" Then
        '    ネットワークドライブの参照
        Call SetCurrentDirectory(ADir)
　  Else
        ' PC内のカレントディレクトリの変更は、ChDrive と ChDir との
        ' セットで行う。
        ChDrive Left(ADir, 2)      <-- PC内ドライブの参照
        ChDir ADir                 <-- ドライブ内のパスの参照
    End If
   End If
   '
   ' Sname=( 変更前のファイル名 )      CCC=( 変更後のファイル名 )
   '
   DirA = Sname: DirB = CCC & ".jpg"
   '
   Name DirA As DirB

マクロで設定したメニューコマンド( マクロを起動させるためのメニューの起動用ボタン )が消えず に残った時には、「セルの操作マクロ」の中にある[ 不要メニュー消去 ]のボタンをクリックすると 簡単に消すことができます。

マクロの記述では、下記の様に書くとマクロで設定したアドイン メニューコマンドをすべて消去 できます。

 Application.CommandBars("Worksheet Menu Bar").Reset

個別にメニュー項目を指定して消去するには、下記の様にします。

 CommandBars("Worksheet Menu Bar") 
                           _.Controls("[メニュー項目]").Delete

※※ 参考情報 ※※

Excel 2016 からは、アドイン メニューコマンドを表示する前に、一度上記コマンドを実行させ、 リセットしてから、表示させるようにすることを勧めます。

※※ お知らせ ※※

メニューコマンド消去とExcel画面の初期化するマクロを作りました。 単に Excel ブックを開くだけです。タイマーを仕込んでいますので自動で終了します。

マクロのダウンロードは、【ここをクリックしてください。】

H25.06.11 追加
「 動的配列変数 」私も結構長いことExcelマクロに触れていますが、勉強不足で最近「 動的配列変 数 」と言う変数を知る機会があり、便利そうなので、早速使ってみました。
また、改めて参考書をその気で見直したら、ちゃんと書いてありました。
その時は、見ても必要性が分からないのでしかたかないですよね。

配列変数は、一般的にその要素数を DIM で変数名と要素数を宣言して使用しますが、動的配列変数は 事前に要素数を計算や推測して宣言することなく使用できる変数です。

つまり、動的配列変数の要素数は、実行の度にプログラム内で定義できるのです。
多分、解説してもピンとこない方の方が多いと思います。

例えば、ドラッグされた範囲をコピーするマクロを考えた場合、ドラッグ範囲のセルの高さ・幅を記 憶させるために配列変数を使用するとすると、「配列変数の要素数 = ドラッグ範囲」となり 制限を付けなくてはならなくなります。このように、要素数を決めると、制限事項が発生するような マクロを作成する時に、動的配列変数を使うとこの制限を付けることなく、マクロを作る事が出来ます。

下記に、ドラッグ範囲を追加シートへコピーするマクロを紹介します。

「 動的配列変数 」を使ったマクロは、「シート操作マクロ」としてダウンロードできます。
シート操作マクロ」では、追加シート・追加ブックへのコピーと「計算式を付ける」も指定できるようにしています。

参考データ マクロ実行時に一個の変数が占めるメモリ量(先人の知恵を借用)

VBAの文字列型(String/可変長)は、10バイト＋文字列の長さ(0～2GB)のメモリが必要です。
また、どのデータ型の配列にも、(20バイトのメモリ)+(各配列の次元ごとに4バイト)+(データその ものが占めるバイト数)を合計したメモリが必要とすると書かれています。

[ドラッグ範囲を追加シートへコピーするマクロ]のプログラムの例です。
Sub コピー() とかにして、サブルーチンとして書込み使用してください。

    Dim Bname, Sname, CCC As String
    Dim x1, y1, x2, y2 As Long
    Dim N As Single
    Dim Takasa() As Variant      <-- 動的配列変数の使用を宣言する。
    Dim Haba() As Variant
    '
    Sname = ActiveSheet.Name     <-- コピー元シート名退避
    ' ドラックされた範囲の始点位置・大きさを取得する。
    With ActiveWindow.RangeSelection
        x1 = .Columns.Column                   <-- 横方向の始点
        x2 = .Columns(.Columns.Count).Column   <-- 横方向のセル数
        y1 = .Rows.Row                         <-- 縦方向の始点
        y2 = .Rows(.Rows.Count).Row       <-- 縦方向のセル数
    End With
    '-------------------------------------------------------------
    ' 動的配列変数の宣言
    '
    ReDim Takasa(y2)         <-- 動的配列変数の要素数を決める。
    ReDim Haba(x2)
    '------------------------------------------------------------
    ' ドラックされた範囲のセルの高さを取得して配列へ代入する。
    For N = y1 To y2
        Takasa(N) = Selection.Rows(N).RowHeight
    Next N
    ' ドラックされた範囲のセルの幅を取得して配列へ代入する。
    For N = x1 To x2
        Haba(N) = Selection.Columns(N).ColumnWidth
    Next N
    '------------------------------------------------------------
    Sheets.Add                   <-- シートを追加する。
    CCC = ActiveSheet.Name       <-- 追加シート名退避
    '
    Worksheets(Sname).Activate   <-- コピー元シート開く
    Selection.Copy               <-- ドラック範囲をコピーする。
    '  追加シートをオープンする。
    Worksheets(CCC).Activate     <---- 新規シートを開く
    '------------------------------------------------------------
    Application.ScreenUpdating = False   <-- 画面更新を停止する。
    Cells(y1, x1).Select                 <-- 張付ける始点を指定する。
    '------------------------------------------------------------
    'Selection.PasteSpecial Paste:=xlValues    '値の貼付
    'Selection.PasteSpecial Paste:=xlFormats   '書式の貼付
    'Selection.PasteSpecial Paste:=xlFormulas  '数式の貼付
    '------------------------------------------------------------
    '  Operation:=xlNone,演算は「行わない」（Operation:=xlNone）
    '　SkipBlanks:=False　「空白を 無視する」 はオフ
    '　Transpose:=False　 「行列を入れ替える」はオフ
    '------------------------------------------------------------
    '   セルの値のみ貼付け
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    '------------------------------------------------------------
    '   セルの書式のみ貼付け
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _  
    SkipBlanks:=False, Transpose:=False
    '------------------------------------------------------------
    '   数式の貼付をする時は、下記行を有効にする
    'Selection.PasteSpecial Paste:=xlFormulas, _
    'Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    '------------------------------------------------------------
    ' 配列へ代入されたセルの高さを読出し同じセル位置に復元する。
    For N = y1 To y2
        Rows(N).RowHeight = Takasa(N)
    Next N
    ' 配列へ代入されたセルの幅を読出し同じセル位置に復元する。
    For N = x1 To x2
        Columns(N).ColumnWidth = Haba(N)
    Next N
    '------------------------------------------------------------
    '   ゼロを表示しない指定は、下記行を有効にする。
    ' ActiveWindow.DisplayZeros = False
    '------------------------------------------------------------
    Application.ScreenUpdating = True <-- 画面更新を停止を解除する。
    Range("A1").Select

出勤台帳・日報等作成使用とする、月末の処理・土日の処理をしなければなりません。これらをマク ロでする時には、下記の様にします。

① 月末を日を知る方法

     Dim YYMMDD, YY, MM, DD As String   <-- 変数を文字列型で宣言
     Dim E_date As Date                    <-- 変数を日付型型で宣言
     Dim EE, N As Integer                  <-- 変数を整数型で宣言
  
     ' YY は、通常西暦ですが、和暦 H25 でもＯＫです。
     YYMMDD = YY & "/" & MM & "/" & DD      <-- 日付型データを作る。
     '                                           ( yyyy/mm/dd )
     ' 指定月(YYMMDD)の末日の年月日を取得する関数への設定

     E_date = DateSerial(Year(YYMMDD), Month(YYMMDD) + 1, 0)

     EE = Day(E_date)          <-- 日付データから日を求める関数、

' 月末の日を知る。 　　※※ 参考情報 ※※

　　( Date は、日付関数 今日の年月日を求める。)
　　 前月の月末日を知る。

     DateSerial(Year(Date), Month(Date), 0)

　　 今月の月末日を知る。

     DateSerial(Year(Date), Month(Date) + 1, 0)

　　 翌月の月末日を知る。

     DateSerial(Year(Date), Month(Date) + 2, 0)

② 曜日を知る方法

     YYMMDD = YY & "/" & MM & "/" & DD   <-- 日付型データを作る。
     '                                         ( yyyy/mm/dd )
     N = Weekday(YYMMDD)        <-- 何曜日かを教えてくれる関数

Weekday(YYMMDD) の戻り値 日= 1,月 = 2,火 = 3,水 = 4,木 = 5,金 = 6,土 = 7
if分とか、Select Case等で判定すれば、曜日ごとの処理ができます。

曜日名を取得する関数( WeekdayName )で 曜日 ( 日 ～ 土 ) を知る方法

この関数は、WeekdayName([曜日を示す数値], [文字"曜日"の付加の有(False)無(True)], [数値=1 の時の曜日を指定]) なので Weekday 関数は、曜日の数値に対してこの関数は、文字で曜日を返します。

Youbi = WeekdayName(Weekday(YYMMDD), True, vbSunday)
Weekday(YYMMDD)=1 --> 日 True : "曜日" 文字無し vbSunday : 基準の曜日--> 日
この結果、変数 Youbi に 曜日 ( 日 ～ 土 ) が代入される。
つまり、WeekdayName(N, True, vbSunday) として N　を 1 ～ 7 に変換すると日～土の曜日が得られます。

ex. 曜日を判定して、書き込んだ日にちの文字に色を付けるプログラム

    N = Weekday(YYMMDD)                   <-- 曜日を抽出
    ' 
    III = Day(YYMMDD)               <-- 日にちを抽出
    '
    ActiveSheet.Cells(y, x).Value = III    <-- 日を設定
    ActiveSheet.Cells(y, x).Select         <-- セル(y, x)を選択
    '
    Select Case N
        Case 1     ' Sunday
            '  色コード 1: 黒, 2: 白, 3: 赤, 4: 緑
            '  色コード 5: 青, 6: 黄, 7: マゼンタ, 8: 水色
            Selection.Font.ColorIndex = 3    <-- 赤
        Case 7     ' Saturday
            Selection.Font.ColorIndex = 5    <-- 青
    End Select
    '
    With Selection     <-- 文字をセルのセンターに表示させる。
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

③ マクロでの年月日の扱い方 ( D_date は、日付型変数 )

     YY = Format(D_date, "yyyy")    <--- 西暦 2019
     YY = Format(D_date, "ge")      <--- 和暦 H○ or R○
     YY = Format(D_date, "ggge")    <--- 和暦 平成○ or 令和○
     MM = Format(D_date, "mm")      <--- 月 01 ～ 12
     MM = Format(D_date, "m")       <--- 月  1 ～ 12
     DD = Format(D_date, "dd")      <--- 日 01 ～ 31
     DD = Format(D_date, "d")       <--- 日  1 ～ 31

※※ 参考情報 ※※ 日付の書式記号 ( 日付の例は、2019/5/1,和暦の例は、令和 1 年 ) ( 2019/4/30 までは、平成 )

  ------------------------------------------------------------
  | 種 類          | 記 号 | 表示例 | 記 号 | 表示例 | 記 号 |
  ------------------------------------------------------------
  | 西 暦 ( 年 )   |   yy  |   19   | yyyy  |  2019  |       |
  | 和 暦 ( 元号 ) |    g  |  H , R |   gg  | 平, 令 |  ggg  |
  | 和 暦 ( 年 )   |    e  |    1   |   ee  |   01   |       |
  ------------------------------------------------------------
  |   月           |    m  |    7   |   mm  |    07  |  mmm  |
  |   日           |    d  |    6   |   dd  |    06  |       |
  ------------------------------------------------------------
  | 曜 日          |  ddd  |  Sun   | dddd  | Sunday |  aaa  |
  ------------------------------------------------------------

  ---------------------------------------------
  | 種 類          | 表示例  | 記 号 | 表示例 |
  ---------------------------------------------
  | 西 暦 ( 年 )   |         |       |        |
  | 和 暦 ( 元号 ) |平成 令和|       |        |
  | 和 暦 ( 年 )   |         |       |        |
  ---------------------------------------------
  |   月           |  Jul    | mmmm  |  July  |
  |   日           |         |       |        |
  ---------------------------------------------
  | 曜 日          |  日     | aaaa  | 日曜日 |
  ---------------------------------------------

④ 日付データの操作(演算)の仕方

     # 変数を日付型で宣言
     Dim D_date, A_date As Date
     # 変数を長整数型で宣言
     Dim abc As Long
     # 数値を日付型  ( yyyy/mm/dd )に変換
     D_date = CDate(abc)
     # 年(A_dateの日付データ)を  +1 (翌年)する。
     D_date = DateAdd("yyyy", 1, A_date)
     # 月(A_dateの日付データ)を  +1 (翌月)する。
     D_date = DateAdd("m", 1, A_date)
     # 日(A_dateの日付データ)を  -1 (前日)する。
     D_date = DateAdd("d", -1, A_date)

　　上記のマクロを使用した、出勤台帳作成マクロ・作業日報_作成マクロを公開しています。
　　下記からダウンロードしてください。

○ シート上で関数を使用して、プログラムの簡素化とスピードアップ図りましょう。

下記の様に、関数を使用するとプログラムも簡単になるし、特に、検索をマクロで書くと、処理が 長くなり、処理の仕方によっては、暴走することもあります。
関数にするとスピードアップにもなり、一石二鳥になります。

　関数を使って検索する例として、
　( 例 1 )として、表から、求める所得税のように、対象となる数 値が、どこの範囲に入るかを求め、その位置から、結果を求めるやり方。
　( 例 2 )として、ダイレクトに一致する位置を求めるやり方を紹介します。

① 例 1

表( 下記表 3.1を参考 )から所得税を取得する方法

セル 2,10 には、マクロで、所得税を取得したい対象金額を書込みます。
セル 5,10 ～ 表の終わりまで、関数 =AND(RC[-9]<=R2C10,R2C10<=RC[-8]) を書き込む
　　　　この処理は、セル 2,10 の金額と左の金額範囲をチェックし、
　　　　　　　　　範囲に入っている時　　-->　true にする、
　　　　　　　　　範囲に入っていない時　-->　false にする。
セル 4,10 に、文字 "true" を書き込む
セル 3,10 に、関数　=MATCH(R[1]C,R[2]C:R[147]C,0) を書き込む
この処理は、セル 4,10 の内容(true)と同じ内容が相対セル位置 2 ～ 表の終わりまで(相対 位置147)をチェックし、そのセルの相対位置が書き込まれます。
該当ないときには、エラーになるので、注意してください。
エラー処理をするには、例 2 の方法で行ってください。

表 3.1 所 得 税 税 額 表

所得金額と扶養家族から、所得税を表検索するマクロを公開しています。
下記からダウンロードしてください。 令和 ４ 年度分源泉徴収税額対応版です。
関数を併用するといかに簡単なプログラムになるかがわかります。

国税庁( https://www.nta.go.jp/ )の給与所得の源泉徴収税額表（月額表)のダウンロードは、 国税庁のホームページの ホーム > 税について調べる > パンフレット・手引き のページ内「源泉徴収税額表関係」から、 「令和○年分源泉徴収税額表」をクリックして源泉徴収税額表から、Excel 版 [ 給与所得の源泉徴収税額表（月額表）（1から7ページ） ] のダウンロードができます。
( 該当ページの下の方にあります。)

※ 簡単な機能説明 ※

① 給与の計算結果は、計算書から、個人に渡す明細書へ転記は、ボタンクリックだけできます。

② 給与計算書・明細書は、ボタンクリックだけでシートの後ろへ、月名を付けてコピーできます。

③ コピーした給与計算書・明細書は、書き変えできないように保護かけています。
セルの保護の解除・保護の設定は、「セル操作マクロ」で簡単にできます。

④ このマクロは、ある企業が現在使用しているマクロから、一般企業用に編集しなおしたマクロ なので、そのまま使用することが出来ると思います。

⑤ 給与計算書は、固定給・日給に対応しています。
残業時間給の計算も自動的に計算します。

⑥ 給与計算書と明細書との読み書きの位置情報は、すべてシート上の表で管理していますので明 細書の様式を簡単に変更できる様になっています。

下記のダウンロードは、税額表から所得税を取得する部分のみのマクロです。

② 例 2

　　表( 下記表 3.2を参考 )から住所をを取得する方法
　　セル 2,5 に、マクロで、住所を取得したい郵便番号を書込みます。
　　セル 2,4 に、関数 =MATCH(R[1]C,R[2]C:R[1867]C,0)+3 を書き込む。
　　　　　 +3 は、相対位置をここで、絶対位置にしています。
　　セル 2,6 に、関数 =ISNA(R[2]C) を書き込む
　　　　　関数 ISNA は、指定したセルが、「 #N/A 」かチェックする関数です。
　　　　　該当ないときには、該当なしのメッセージを表示します。
　　関数 ISNA は、表検索の時は、入れて適切な処理をするようにしてください。<

表 3.2 住 所 一 覧 表

　　　郵便番号から、住所を表検索するマクロを公開しています。
　　　下記からダウンロードしてください。