| 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
シート送りの制御変数の初期値を設定
' １ページ目
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 As Integer
Public 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"は、整数表示指定、３桁目カンマ有
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 <---- シートの数を取得する。
シートを１ページ毎、表示し、シート名を取得し、「マクロの表紙」の
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 <----キャンセルの時は、終了する。
' １番目のシート名
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列目に書込まれているシート名に従って、
２番目以降を移動する。
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", "Ｒ"
nn = nn + 1
Case "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 |
|