www.smiyasaka.com  は、2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。

● Excel マクロの解説 「シートの操作マクロ 」編 ●

3 5,759 2   

「 写真貼付マクロ 」について、簡単ですが赤字で解説を入れました。
参考になれば、幸いです。

H25.06.20 現在
------------------   ここから ThisWorkBook コード ---------------------
ブックを閉じた時に、アドインとユーザーフォームを消去する
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    SAA02リセット
End Sub
-----------------------------------------------------------------------
ブックを開いた時に、アドインの設定とForm2のユーザーフォームを開く
Private Sub Workbook_Open()
    SAA01セット
End Sub
-----------------------------------------------------------------------
[シート名抽出]ボタンクリックでシート名抽出を実行
Private Sub CommandButton10_Click()
   シート名取得
End Sub
-----------------------------------------------------------------------
[シート名リスト並替]ボタンクリックでシート名リストの内容に従って
シートの並び替えを実行
Private Sub CommandButton2_Click()
    B1name = ActiveWorkbook.Name         <---- 本マクロのブック名取得。
    If B1name <> AAname Then Exit Sub    <---- 本マクロで無い時には
    シート名整理                                                   強制終了
End Sub
-----------------------------------------------------------------------
[シート並替開始]ボタンクリックでシート並替を実行
Private Sub CommandButton3_Click()
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub  <-- 本マクロの時には、強制終了
    シート並替
End Sub
-----------------------------------------------------------------------
[計算式を取ってコピー]ボタンクリックで計算式なしでシートコピーを実行
Private Sub CommandButton30_Click()
    計算式なしコピー
End Sub
-----------------------------------------------------------------------
[シートコピー]ボタンクリックでシートコピーを実行
Private Sub CommandButton4_Click()
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub
    シートコピー
End Sub
-----------------------------------------------------------------------
[シート名色付け]ボタンクリックでシート名色付けを実行
Private Sub CommandButton5_Click()
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub
    シート名色付け
End Sub
-----------------------------------------------------------------------
[シート名色消し]ボタンクリックでシート名色消しを実行
Private Sub CommandButton6_Click()
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub
    シート名色消し
End Sub
-----------------------------------------------------------------------
[シート名色なし抽出]ボタンクリックでシート名色なし抽出を実行
Private Sub CommandButton7_Click()
    Dim Btn As Integer
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub
    色付をシート削除を実行して良いかを、Yes/No で聞く処理
    Btn = MsgBox("色付をシート削除します", vbYesNo, "消去確認")
    If Btn = vbNo Then Exit Sub    <---- NO の時には、強制終了。
    Aシート名色なし抽出
End Sub
-----------------------------------------------------------------------
[シート名色有抽出]ボタンクリックでシート名色有抽出を実行
Private Sub CommandButton8_Click()
    Dim Btn As Integer
    B1name = ActiveWorkbook.Name
    If B1name = AAname Then Exit Sub
    Btn = MsgBox("色なしをシート削除します", vbYesNo, "消去確認")
    If Btn = vbNo Then Exit Sub
    Aシート名色有抽出
End Sub
-----------------------------------------------------------------------
[シート印刷]ボタンクリックでシート印刷を実行
Private Sub CommandButton9_Click()
    B1name = ActiveWorkbook.Name
    表示されているシートが「マクロの表紙」で無かったら、
    警告メッセージ表示する。

    If B1name <> AAname Then
        Workbooks(AAname).Activate>    <--「マクロの表紙」を表示
        MsgBox ("印刷範囲を指定してください。")
        Exit Sub
    End If
    CheckBox1(フッター印字)にチェックがある時には、フラグをONする。
    If UForm1.CheckBox1 = True Then Futa = 1
    Pprint Futa
End Sub
-----------------------------------------------------------------------
[先頭出し]ボタンクリックでシート 1 を表示する
    '----------------------------------------------------
'               シート送り
    '----------------------------------------------------
Private Sub CommandButton11_Click()
    ' 抽出したデータシートの各ページ先頭だし
    
    ii = Worksheets.Count    <---- シートの数を取得。
    すべてのシートの表示を見やすいように初期値
    (セル 1,1 を左上端で表示)状態にする
    For i = 1 To ii
        Worksheets(i).Activate
        ActiveSheet.Cells(1, 1).Select
    Next i
    シート送りの制御変数の初期値を設定
    '  1ページ目
    Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 1
    '  送り方向 右
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = "R"
    Worksheets(1).Activate                                <---- シート 1 表示
    MsgBox "作業完了"                                     <---- 完了メッセージ表示
End Sub
-----------------------------------------------------------------------
[→]ボタンクリックでシートの右送りを実行
Private Sub CommandButton12_Click()
    ' シート右送り    送りフラグを右する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = "R"
    Aシート送り                                               <---- シート送りをする。
End Sub
-----------------------------------------------------------------------
[←]ボタンクリックでシートの左送りを実行
Private Sub CommandButton13_Click()
    ' シート左送り     送りフラグを左する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = "L"
    Aシート送り                                               <---- シート送りをする。
End Sub
-----------------------------------------------------------------------
[現位置指定]ボタンクリックで現在表示されているシートを
基準位置とする設定を実行
Private Sub CommandButton14_Click()
    AAA = ActiveSheet.Name                         <--- シート名を取得する。
    Scnt = Worksheets.Count                        <--- シート枚数を取得する。
    現在表示されているシートが何番目かを知る。
    For i = 1 To Scnt
    i 番目のシート名と AAA のシート名が同じの時、For 文を出る。
         If Worksheets(i).Name = AAA Then Scnt = i: Exit For
    Next i
    現在表示のシートの番号を「マクロの表紙」の所定のセルへ保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = Scnt
End Sub
-----------------------------------------------------------------------
[コピーを実行]ボタンクリックで現在表示されているシートを
基準位置とする設定を実行
Private Sub CommandButton15_Click()
    ドラック範囲コピー
End Sub
-----------------------------------------------------------------------
[同一ブック内]オプションボタンにチェックが入ったら Label6 の
メッセージを替える。
Private Sub OptionButton1_Click()
 If UForm1.OptionButton1 = True Then _
                UForm1.Label6.Caption = "同一ブックにコピーします。"
End Sub
-----------------------------------------------------------------------
[新規ブック]オプションボタンにチェックが入ったら Label6 の
メッセージを替える。
Private Sub OptionButton2_Click()
 If UForm1.OptionButton2 = True Then _
                UForm1.Label6.Caption = "新規ブックにコピーします。"
End Sub

-----------------------------------------------------------------------
Uform1のイニシャライズ処理
Private Sub UserForm_Initialize()
    シート送りの制御変数の初期値を設定    表示シート位置
    Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 1 
    '    シート送り方向
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = "R"
    UForm1.OptionButton1 = True  <---- ドラック範囲のコピーの初期値を
End Sub                                              を同一ブック内にする。
-------------------   ここから module1のコード    --------------------
マクロブック・シートの名前を定義、変数の宣言
  Public x, y, x1, y1, x2, y2, x3, x4 As Long
  Public mm, N, N1, N2, N3, N4, nn, ii, iii, Bcnt, CNT, Scnt, zz As Integer
  ' AAnameとBBnameは、変更しないでください。
  ' ブック名を変更した時は、AAnameの名前も、ブック名に変更してください
  Public Const AAname As String = "シートの操作マクロ.xlsm"
  Public Const BBname As String = "表紙"
  Public B1, S1, SS As String
  Public ABname, ASname, folda As String
  Public AAA, BBB, CCC, DirA, DirB, Fname, Rname, RBname As String
  Public myPath, aa, Bname, Xname As String
  Public Fname1, Fname2, Fname3, B1name, S1name As String
  Public myFname, Sname, Gname, Tname, dir1, HH As String

-----------------------------------------------------------------------
Excelブックがオープンした時に実行するサブルーチン
Sub auto_open()
/span>    '----------------------------------------------------
    '  Excel 起動時にメニューバーをアドインに移動させる処理
    '----------------------------------------------------

    この様にしないといつまでも Excelブックがオープンしない
    '    タイムディレー処理   直ぐに、サブルーチン AddIN を実行させる
    Application.OnTime Now + TimeValue("00:00:00"), "AddIN"
End Sub
-----------------------------------------------------------------------
メニューバーを「アドイン」に移動させる処理
Sub AddIN()
    Sheets(BBname).Select            <---- 所定のシートを表示させる
    N = Val(Application.Version)     <---- Excelのバージョンを取得する
     
    Excelのバージョンの"2000 ; 9","2002 ; 10","2003 ; 11"時は、何もしない
    If N = 9 Or N = 10 Or N = 11 Then Exit Sub
    
    Excelのバージョンの"2007 ; 12","2010 ; 14","2013 ; 15","2016 ; _
     16"時は、アドインに移動
    '  [ALT]-->[X]-->[ALT]のキー入力を実行
    Application.SendKeys ("%X%")
    
End Sub
-----------------------------------------------------------------------
アドインの表示処理
Sub SAA01セット()
    Dim Mycontrol As CommandBarControl
    Dim mysubmenu As CommandBarControl
    Set Mycontrol = CommandBars("Worksheet Menu Bar"). _
    Controls.Add(msoControlPopup)
    Mycontrol.Caption = "(■)"
    Mycontrol.OnAction = "UForm1表示"
End Sub
-----------------------------------------------------------------------
アドインの削除処理
Sub SAA02リセット()
    CommandBars("Worksheet Menu Bar").Controls("(■)").Delete
End Sub
-----------------------------------------------------------------------
ユーザーフォームの表示処理
Sub UForm1表示()
    UForm1.Show vbModeless
End Sub
-----------------------------------------------------------------------
シート名に枝番号を付けてシートコピーをするサブルーチン
Sub シートコピー()
    念のため、ブックの共有を解除しておく
    '-------------------------------------------------------------------------
    '   Excel 2007/2010 対策
    ' ブックの共有解除をしないとシートコピーできない。
    Application.DisplayAlerts = False
    If ActiveWorkbook.MultiUserEditing Then _
                                 ActiveWorkbook.ExclusiveAccess
    Application.DisplayAlerts = True
    '------------------------------------------------------------------------
    Fname = ActiveSheet.Name    <---- シート名を取得する。
    SS = Len(Fname)     <---- シート名の文字数を取得する。
    枝番が有るかの情報取得・枝番を取った文字数を取得する。
    N4 = InStr(1, Fname, "-"): S1 = SS - N4 + 1
        If N4 <> 0 Then         <---- 枝番が有るか?
            BBB = Left(Fname, SS - S1)    <---- 枝番を取ったシート名を取得
            枝番のみを取得・枝番を数値に変換する。
	    HH = Right(Fname, SS - N4): N = Val(HH)
            AAA = BBB & "-" & CStr(N + 1)      <---- 枝番付のシート名を作る。
        Else     ' 枝番が無い時は、-1 を付ける
            AAA = Fname & "-" & CStr(1)
        End If
    ' 注意 同じ名前がある時には、エラーになります。
    On Error GoTo シートコピーerr:       <---- エラー時のジャンプ先
    Application.DisplayAlerts = False    <---- 警告メッセージの表示を停止
    mm = ActiveSheet.Name
    Sheets(mm).Copy After:=Sheets(mm)    <---- シートを後ろへコピー
    CCC = ActiveSheet.Name
    Worksheets(CCC).Name = AAA          <---- シート名を変更する。
    Application.DisplayAlerts = True     <----警告メッセージの表示を停止を
    Exit Sub                                                         解除する。
    '
シートコピーerr:
    zz = Err.Number
    ' 同じシート名有る時は、シート名に(n)を付けて、こぴーする。
    エラー番号:1004は、同一シート名有り。警告メッセージ表示
    If zz = 1004 Then MsgBox ("同じシート名があります。エラー番号 : " _
                                                                    & Err.Number)
End Sub

Sub 図形位置サイズ()
-----------------------------------------------------------------------
選択された図形位置・サイズを表示するサブルーチン
With Selection
    x1 = .Left
    y1 = .Top
    x2 = .Width
    y2 = .Height
End With
    Format文 "#,##0"は、整数表示指定、3桁目カンマ有 
    MsgBox " 左 " + Format(x1, "#,##0") + " 上 " + Format(y1, _
    "#,##0") + "  横幅 " + Format(x2, "#,##0") + " 縦幅 " _
     + Format(y2, "#,##0")
       
End Sub
-----------------------------------------------------------------------
「シート名色付け」クリックで、シート名に色を付けるサブルーチン
Sub シート名色付け()
    AAA = ActiveSheet.Name
    Sheets(AAA).Select
    '  シート名色付け 薄黄色。
    ActiveWorkbook.Sheets(AAA).Tab.ColorIndex = 36
End Sub
-----------------------------------------------------------------------
「シート名色消し」クリックで、シート名に色を付けるサブルーチン
Sub シート名色消し()
    AAA = ActiveSheet.Name
    Sheets(AAA).Select
    ' シート名の色を消す。
    ActiveWorkbook.Sheets(AAA).Tab.ColorIndex = -4142
End Sub
-----------------------------------------------------------------------
「シート名抽出」クリックで、「マクロの表紙」の10列目に
シート名を書込むサブルーチン

Sub シート名抽出()
    nn = Worksheets.Count    <---- シートの数を取得する。
 シートを1ページ毎、表示し、シート名を取得し、「マクロの表紙」の
 10列目にシート名を書込む
    For N = 1 To nn
        Worksheets(N).Activate    <---- N番目のシートの表示する。
        「マクロの表紙」の10列目にシート名を書込む。
        Workbooks(AAname).Worksheets(BBname).Cells(N, 10).Value = _
                                                                            ActiveSheet.Name
    Next N
  
    MsgBox "抽出終了"
End Sub
-----------------------------------------------------------------------
「マクロの表紙」の10列目に書込まれているシート名を
整列させるサブルーチン

Sub シート名整理()
    「マクロの表紙」の10列目のどこまでシート名が
    書込まれているかを調べる。
    nn = ActiveSheet.Range("J2000").End(xlUp).Row
    AAA = "J2:J" & CStr(nn)   <----ソートするセル範囲を作る。
    Range(AAA).Select         <----ソートするセル範囲を選択する。
    Range("J2").Activate
    「マクロの表紙」の10列目のシート名がソート(並び替え)する。
    Selection.Sort Key1:=Range("J2"), Order1:=xlAscending, _
     Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
     Orientation:=xlTopToBottom, SortMethod _
     :=xlPinYin, DataOption1:=xlSortNormal
End Sub
-----------------------------------------------------------------------
「マクロの表紙」の10列目に書込まれているシート名に従ってシートを
並び替えるサブルーチン

Sub シート並替()

    Dim Btn As Integer
    並び替えをして良いかを聞く(OK,キャンセル)。
    Btn = MsgBox("シートを並び換えます。", vbOKCancel, _
           "シート並び換えの確認")
    If Btn = vbCancel Then Exit Sub   <----キャンセルの時は、終了する。
    '   1番目のシート名
    AAA = Workbooks(AAname).Worksheets(BBname).Cells(2, 10).Value
    BBB = Sheets(1).Name                      <-- 表示されているのシートの名
    シート名AAAとBBBが違ったら、シートBBBの前にシートAAAを移動する。
    If AAA <> BBB Then
        Sheets(AAA).Move before:=Sheets(BBB)
    End If
    「マクロの表紙」の10列目に書込まれているシート名に従って、
      2番目以降を移動する。
    For nn = 2 To Sheets.Count - 1
      Sheets(Workbooks(AAname).Worksheets(BBname).Cells(nn + 1, _
       10).Value).Move After:=Sheets(nn - 1)  <-- 前回並び替えた最終シート
    Next nn
End Sub
-----------------------------------------------------------------------
シート名に色が付いていないシートを消去するサブルーチン
Sub Aシート名色有抽出()
    Dim Xcnt, ii As Single
    Xcnt = Worksheets.Count
    Application.DisplayAlerts = False    <-- 警告メッセージの表示を停止する。
    nn = 1
    For ii = 1 To Xcnt
        Worksheets(nn).Activate
        AAA = ActiveSheet.Name
        Sheets(AAA).Select
        シート名に色が付いていないか(色なし)判定する。
        If ActiveWorkbook.Sheets(AAA).Tab.ColorIndex <> 36 Then
           ActiveWindow.SelectedSheets.Delete     <-- シートに色が
           Xcnt = Xcnt - 1: nn = nn - 1                       無かったら消去する。
        End If
        nn = nn + 1
    Next ii
    Application.DisplayAlerts = True     <-- 警告メッセージの表示を停止を
                                                               を解除する。
End Sub
-----------------------------------------------------------------------
シート名に色が付いているシートを消去するサブルーチン
Sub Aシート名色なし抽出()
    Dim Xcnt, ii As Single
    Xcnt = Worksheets.Count
    Application.DisplayAlerts = False      <----警告メッセージの表示を停止
    nn = 1
    For ii = 1 To Xcnt
        Worksheets(nn).Activate
        AAA = ActiveSheet.Name
        Sheets(AAA).Select
        シート名に色が付いているか(色有)判定する。
        If ActiveWorkbook.Sheets(AAA).Tab.ColorIndex = 36 Then
           ActiveWindow.SelectedSheets.Delete     <----シートに色がついて
           Xcnt = Xcnt - 1: nn = nn - 1                        いたら消去する。
        End If
        nn = nn + 1
    Next ii
    Application.DisplayAlerts = True       <----警告メッセージの表示を
                                                                停止を解除する。
End Sub
-----------------------------------------------------------------------
すべてのシート名の色なしにするサブルーチン
Sub Aシート名色無()
    Dim Xcnt, ii As Single
    Xcnt = Worksheets.Count
    For ii = 1 To Xcnt
        Worksheets(ii).Activate
        AAA = ActiveSheet.Name
        Sheets(AAA).Select
        '  シート名を色なしにする。
        ActiveWorkbook.Sheets(AAA).Tab.ColorIndex = -4142
    Next ii
    Worksheets(1).Activate
End Sub
-----------------------------------------------------------------------
シート送りデータに従ってシート送りをするサブルーチン
Sub Aシート送り()

    Scnt = Worksheets.Count
    シート送りデータを「マクロの表紙」から読み出す。
  '  右・左フラグ
 AAA = Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value
  '  基準となるシート番号
 nn = Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value
  シートの送り方向を判定する。
    Select Case AAA
        Case "R", "R"
            nn = nn + 1
        Case "L", "L"
            nn = nn - 1
    End Select
      シートの先頭/最後の時は、シート送りしないで終了する。
        If nn <= 0 Or nn = Scnt + 1 Then GoTo Aシート送りend:
    Worksheets(nn).Activate                    <----シート送りをする。
        現在表示しているシートの番号を保存する。
        Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = nn    
Aシート送りend:
End Sub
------------------   ここから module2のコード    ---------------------
マクロブック・シートの名前を定義、変数の宣言
Sub シート名取得()
    Dim C_Range As Variant
    「マクロの表紙」にブック名・シート名を保存する。
    Bname = ActiveWorkbook.Name          ' ブック名取得
    Sname = ActiveSheet.Name             ' シート名取得
    Workbooks(AAname).Worksheets(BBname).Cells(3, 1).Value = Bname
    Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value = Sname
    '
    Application.ScreenUpdating = False             <----画面更新を停止する。
    「マクロの表紙」表示する。
    Workbooks(AAname).Activate
    Worksheets(BBname).Activate
    「マクロの表紙」にブック名・シート名を書き込んでいるデータを消去する。
    ' シート枚数カウント関数書込み
    ActiveSheet.Cells(1, 11).FormulaR1C1 = _
                           "=COUNTA(R[1]C[-1]:R[1000]C[-1])"
    'セルの内容を消去する
    '  書込みデータの数+1を取得する。
    N = ActiveSheet.Cells(1, 11).Value + 1
    If N > 1 Then                   <----書込みがある時のみ消去する。
        C_Range = "I2:J" & CStr(N)  <----消去範囲をレンジデータを作成
        Range(C_Range).Select       <----消去範囲を選択する。
        Selection.ClearContents     <----書き込むエリヤを消去する。
    End If
    '
    ActiveSheet.Cells(1, 9).Value = "番号"           <----タイトル書き込み
    ActiveSheet.Cells(1, 10).Value = "シート名"
    Range("J2").Select
    
    Application.ScreenUpdating = True    <----画面更新を停止を解除
    Workbooks(Bname).Activate        <----処理対象のブックのシートを表示
    Worksheets(Sname).Activate
    zz = 1: mm = 1
       
    Scnt = Worksheets.Count                   <----シートの枚数を取得
    
    Application.ScreenUpdating = False        <----再度画面更新を停止
    すべてのシートのシート名を「マクロの表紙」に書き込む。
    For nn = 1 To Scnt
    
        Worksheets(nn).Activate
        Workbooks(AAname).Worksheets(BBname).Cells(nn + 1, _
                                                   9).Value = nn
        シート名設定
        Workbooks(AAname).Worksheets(BBname).Cells(nn + 1, _
                                                  10).Value = ActiveSheet.Name
        '
    Next nn
    「マクロの表紙」表示する。
    Workbooks(AAname).Activate
    Worksheets(BBname).Activate
    Application.ScreenUpdating = True       <----再度画面更新を停止を解除

End Sub
-----------------------------------------------------------------------
(おまけ)フォルダ参照を使用しないでパスを取得するサブルーチン
Sub パス設定()
    ' 格納先フォルダ設定
    Dim F_array As Variant
    Dim A_cnt, C_cnt, L_cnt As Intege
    '
    Excelを開くダイヤログを表示する。
    myFname = Application.GetOpenFilename("Excelファイル(*.xls),*.xls")
     '     ファイルが指定されなかったら強制終了する。
    If myFname = False Then Exit Sub
    ファイル名を取ってフォルダのフルパスを作成する。
    AAA = myFname    <----指定されファイルのフルパスデータ
    xx = 1
    '
    '-----------------------------------------------------------------------
    ' 次読込の為のパスを記録する。
        C_cnt = Len(myFname)     ' 選択したExcelファイルのフルパス文字数
        F_array = Split(AAA, "\")    ' \ で分割して 配列 F_array に代入
        A_cnt = UBound(F_array)      ' 現在の大きさ(要素数)を調べます
        CCC = F_array(A_cnt)         ' 最後配列にExcelファイル名がある
        L_cnt = Len(CCC) + 1         ' Excelファイル名の文字数 + \ の分
    「マクロの表紙」に、保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(2, 1).Value = _
                                                               Left(AAA, C_cnt - L_cnt)
    '-----------------------------------------------------------------------
    '
End Sub
-----------------------------------------------------------------------
[シート印刷]ボタンクリックでシートを連続印刷するサブルーチン
Sub Pprint(Futa As Variant)

    With ActiveWindow.RangeSelection    <----リストの印刷指定範囲を取得
        x1 = .Rows.Row
        x2 = .Rows(.Rows.Count).Row
    End With                              ' ドラッグ範囲取得
    '
    N = 1     ' 印刷枚数取得
    印刷対象ブックを表示する。
    Bname = Workbooks(AAname).Worksheets(BBname).Cells(3, 1).Value
    Sname = Workbooks(AAname).Worksheets(BBname).Cells(4, 1).Value
    Workbooks(Bname).Activate
    Worksheets(Sname).Activate
    
        ' シート印刷
        Application.ScreenUpdating = False             <----画面更新を停止
        
        For i = x1 To x2
           「マクロの表紙」のリストから、印刷シート名取得する。
           Fname = Workbooks(AAname).Worksheets(BBname).Cells(i, 10)
           '   取得したシート名のシートを表示する。
           Worksheets(Fname).Activate 
           フッター印字の指定あるか判定する。
           If Futa = 0 Then GoTo PprintLoop02:
           フッターを 6ポイントの文字でシート名を左下に印字させる指定。
           ' フッター印刷
           Xname = "&6" & "  " & ActiveSheet.Name
           With ActiveSheet.PageSetup
               .LeftFooter = Xname
           End With
PprintLoop02:
            If UForm1.CheckBox2 = True Then        <-- プレビュー指定か判定
                '確認
                ActiveWindow.SelectedSheets.PrintPreview <-- プレビュー表示
            Else
                N4 = Val(UForm1.TextBox1.Value)              <----印刷枚数取得
                指定枚数印刷する。
                ActiveWindow.SelectedSheets.PrintOut Copies:=N4, _
                Collate:=True  ' 印刷
            End If
                
        Next i
                
Pprintend:
        Application.ScreenUpdating = True    <----画面更新を停止を解除
    MsgBox "印刷終了"""
End Sub
-----------------------------------------------------------------------
「ドラック範囲コピー」サブルーチン
Sub ドラック範囲コピー()
    '-----------------------------------------------------
    ' 動的配列変数を使用して作成。
    ' 動的配列変数とは、実行する毎に配列の数が、変わる変数
    '-----------------------------------------------------
    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
    '------------------------------------------------------------------------
    ' 同一ブック内にコピー
    If UForm1.OptionButton1 = True Then
        '
        シート追加 Add_sheet     <---- 新規シートを追加するサブルーチンへ
        '
        Worksheets(Sname).Activate     <---- コピー元シート開く
        Selection.Copy                 <---- ドラック範囲をコピーする。
        '  追加シートをオープンする。
        Worksheets(Add_sheet).Activate
    End If
    '-----------------------------------------------------------------------
    ' 選択範囲をコピーして新規ブックのを作成してコピー
    If UForm1.OptionButton2 = True Then
        '
        Selection.Copy                  <---- ドラック範囲をコピーする。
        ブックの追加                    <---- 新規ブックを追加するサブルーチンへ
    End If
    '------------------------------------------------------------------------
    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
    '------------------------------------------------------------------------
    ' セルの数式の貼付 ?
    If UForm1.CheckBox3 = True Then _
        Selection.PasteSpecial Paste:=xlPasteFormulas, _
        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
    '------------------------------------------------------------------------
    ' ゼロを表示しない ?                            <----ゼロを表示しない指定
    If UForm1.CheckBox4 = True Then ActiveWindow.DisplayZeros = False
    '------------------------------------------------------------------------
    Application.ScreenUpdating = True           <----画面更新を停止を解除
    Range("A1").Select

End Sub
-----------------------------------------------------------------------
新規シートをコピー元の後ろへコピーするサブルーチン
'        Add_sheet は、サブルーチンの引数
Sub シート追加(Add_sheet As Variant)
    '-------------------------------------------------------------------------
    '   Excel 2007/2010 対策
    ' ブックの共有解除をしないとシートコピーできない場合があるので処理する。
    Application.DisplayAlerts = False
        If ActiveWorkbook.MultiUserEditing Then _
                                   ActiveWorkbook.ExclusiveAccess
    Application.DisplayAlerts = True
    '------------------------------------------------------------------------
    BBB = ActiveSheet.Name
    If UForm1.CheckBox3 = False Then
    新規シート名をコピー元シートの名前+( 計算式なし )にする
        AAA = BBB & "(" & "計算式なし" & ")"
    Else
    新規シート名をコピー元シートの名前+( 計算式あり )にする
        AAA = BBB & "(" & "計算式あり" & ")"
    End If
    '
    SS = ActiveSheet.Name
    Application.DisplayAlerts = False  <----警告メッセージの表示を停止
    Sheets.Add                         <----新規シートを追加
    CCC = ActiveSheet.Name
    CCC:新規シートの名前、SS:追加シートの名前
    '    新規シートをコピー元シートの後ろへ移動する。
    Sheets(SS).Move After:=Sheets(CCC)
    Worksheets(SS).Name = AAA          <----シート名を変更する。
    '
    Application.DisplayAlerts = True   <----警告メッセージ停止を解除
    '
    Add_sheet = ActiveSheet.Name       <----引数( Add_sheet )に
    '                                                         追加シート名を設定する。
End Sub
-----------------------------------------------------------------------
新規ブックを追加するサブルーチン
Sub ブックの追加()
    BBB = ActiveSheet.Name
    '
    Workbooks.Add                           <----新規ブックを追加する。
    '
    If UForm1.CheckBox3 = False Then
    新規シート名をコピー元シートの名前+( 計算式なし )にする
        AAA = BBB & "(" & "計算式なし" & ")"
    Else
    新規シート名をコピー元シートの名前+( 計算式あり )にする
        AAA = BBB & "(" & "計算式あり" & ")"
    End If
    '
    SS = ActiveSheet.Name
    Worksheets(SS).Name = AAA              <----シート名を変更する。
End Sub

TOPへ戻る