'========================================================================================= ' 499 数式印刷 '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードを含んでいます。（概ね下半分） ' ★★★の行またはサブプロシージャーが、タイトル機能に関係するコードです。（概ね上半分） '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- '----------------------------------------------------------------------------------------- Sub おためしマクロ() 作業選択シートを表示する End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ★ おまかせ数式印刷 V3.2 ★ Copyright(c)1998-2000 Yoshioh Nagai '========================================================================================= Option Explicit Dim バージョン As String 'エクセルのバージョン Dim 情報 As String 'エクセルの通称名 Dim 役立つ名 As String 'このブックの名前 Dim ブック名 As String '数式を調べるブックの名前 Dim シート名 As String '　　〃　　　シートの名前 Dim 下端 As Long '　　〃　　　　　〃　下端行番号 Dim 右端 As Integer '　　〃　　　　　〃　右端列番号 Dim ダミー As String 'ダミーシートの名前 Dim タイトル As String 'メッセージボックスのタイトル Dim スタイル As Variant '　　　　〃　　　　　スタイル Dim メッセージ As String '　　　　〃　　　　　メッセージ Dim yesno As Variant '　　　　〃　　　　　返り値 Dim 桁数 As Integer '行番号の印刷桁数 Dim 縦 As Long '作業用の行カウンタ Dim 行 As Long '　　〃　行　　〃 Dim 列 As Integer '　　〃　列　　〃 Dim 列幅 '数式列の印刷幅（o） Dim 数式エラー As Integer '数式エラー有:1、無:0 Dim 調査セル 'セル内容取り出し用 Dim 調査セルの数式 'セル数式取り出し用 Dim 初期状態 As Variant 'ステータスバーの初期状態 Dim 選択 As Integer 'ユーザーが選択した作業方法 Dim ファイル出力 As Integer 'ユーザーが選択したファイル出力 Dim 新規ブック名 As String 'ファイル出力用のブック名 Dim 列上 As Integer '列番号の上1文字 Dim 列上名 As String '列名の上1文字 Dim 列名 As String '文字列に変換した列名 Dim フォント As String '数式印刷用のフォント指定 Dim サイズ As Integer '同上のサイズ指定 Dim 用紙サイズ As Integer '用紙のサイズ Dim 用紙の向き As Integer '用紙の向き Dim 印刷部数 As Integer '印刷部数 Dim 縦幅限界 As Integer '用紙を縦型にした場合の幅から余白を控除（o） Dim 左フッター As String '左側フッター '========================================================================================= Sub 作業選択シートを表示する() 役立つ名 = ActiveWorkbook.Name 'このブックの名前を覚える ActiveWindow.WindowState = xlMaximized 'ウィンドウを最大表示する Sheets("作業選択").Select '初期画面を映す Range("H16").Select ActiveWindow.Zoom = True 'ズームする エクセルのバージョンを表示する End Sub '----------------------------------------------------------------------------------------- Private Sub エクセルのバージョンを表示する() バージョン = Left(Application.Version, 3) '★★★ エクセルのバージョンを調べる If バージョン = "9.0" Then 'Excel 2000なら 情報 = "Microsoft(R) Excel 2000" ElseIf バージョン = "8.0" Then 'Excel 97なら 情報 = "Microsoft(R) Excel 97 or 98" ElseIf バージョン = "7.0" Then 'Excel 95なら 情報 = "Microsoft Excel for windows 95" Else 'それ以外なら 情報 = "不明" End If Range("E2").Value = 情報 'エクセルのバージョン情報を記入する End Sub '========================================================================================= Sub プレビューA1印刷() 選択 = 2 ファイル出力 = 0 '0=しない 印刷したいシートを選ぶ End Sub ' Sub プレビューR1C1印刷() 選択 = 0 ファイル出力 = 0 印刷したいシートを選ぶ End Sub ' Sub おまかせA1印刷() 選択 = 3 ファイル出力 = 0 印刷したいシートを選ぶ End Sub ' Sub おまかせR1C1印刷() 選択 = 1 ファイル出力 = 0 印刷したいシートを選ぶ End Sub ' Sub おまかせA1出力() 選択 = 3 ファイル出力 = 1 '1=する 印刷したいシートを選ぶ End Sub ' Sub おまかせR1C1出力() 選択 = 1 ファイル出力 = 1 '1=する 印刷したいシートを選ぶ End Sub '----------------------------------------------------------------------------------------- Private Sub 印刷したいシートを選ぶ() Application.ScreenUpdating = False '画面を更新しない 書式設定パラメータを取り出す '----------------------------------------------------------------------------------------- メッセージ = "OKボタンを押してから、数式を印刷したいブックを開いてください" タイトル = " . . このあとの 操作方法 . ." MsgBox メッセージ, vbInformation, タイトル Application.Dialogs(xlDialogOpen).Show arg3:=True '読み取り専用でファイルを開くダイアログを映す ブック名 = ActiveWorkbook.Name '開かれたブックの名前を覚える On Error GoTo エラー処理2 'ブック保護への対策 エラー処理2からの戻り口: Worksheets.Add.Move after:=Worksheets(Worksheets.Count) 'ダミーのシートを追加する ダミー = ActiveSheet.Name 'ダミーシートの名前を覚える Sheets(ダミー).Name = "数式印刷用作業シート" 'ダミーシートの名前を変える ダミー = ActiveSheet.Name Worksheets(ダミー).OnSheetDeactivate = "印刷" 'シートが非アクティブになったら実行するマクロ名 ' ActiveWindow.DisplayWorkbookTabs = True 'シート見出しを表示する Application.ScreenUpdating = True '画面を更新する メッセージ = "OKボタンを押してから、シートを選んでください" & Chr(13) & Chr(13) & _ "（作業用シートが挿入されましたが、心配不要です）" & Chr(13) & Chr(13) & _ "大きなシートなど、かなり時間がかかる場合があります" タイトル = " 数式を印刷したいブックを、読み取り専用で開きました" MsgBox メッセージ, vbInformation, タイトル On Error GoTo 0 'エラー対策を解除 Exit Sub '正常終了 '----------------------------------------------------------------------------------------- エラー処理2: 'エラーが発生した時の入り口 If Err = 1004 Then 'ブック保護されているか Resume ブック保護を解除してみる End If GoTo エラー処理3 '----------------------------------------------------------------------------------------- ブック保護を解除してみる: On Error GoTo 0 On Error GoTo エラー処理3 ActiveWorkbook.Unprotect 'ブック保護解除 GoTo エラー処理2からの戻り口 '----------------------------------------------------------------------------------------- エラー処理3: 'エラーが発生した時の入り口 タイトル = "予期せぬエラーが発生しました(3) ... " & Str(Err) & ": " & Error(Err) メッセージ = " [対処例] パスワード違い … ブック保護解除が必要" & Chr(13) & Chr(13) & _ "作業を中止します。原因を取り除いてから、やり直してください。" MsgBox メッセージ, vbCritical, タイトル Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない Close 'ファイルをすべて閉じる Application.Quit 'エクセルを終了する End Sub '----------------------------------------------------------------------------------------- Private Sub 書式設定パラメータを取り出す() If Sheets("書式設定").Range("D5").Value = "2" Then '数式のフォントの指定 フォント = "ＭＳ 明朝" Else フォント = "ＭＳ ゴシック" End If サイズ = Sheets("書式設定").Range("D6").Value '数式のフォントのサイズ 用紙サイズ = Sheets("書式設定").Range("D7").Value '用紙のサイズ 用紙の向き = Sheets("書式設定").Range("D8").Value '用紙の向き 印刷部数 = Sheets("書式設定").Range("D9").Value '印刷部数 End Sub '========================================================================================= Sub 印刷() Application.ScreenUpdating = False '画面を更新しない Worksheets(ダミー).OnSheetDeactivate = "" 'シートが非アクティブになったら実行するマクロ名消す シート名 = ActiveSheet.Name '開かれたシートの名前を覚える On Error GoTo エラー処理12 '予期せぬエラーへの対策 エラー処理12からの戻り口: Range("A1").SpecialCells(xlLastCell).Select '最後のセルを選択 下端 = ActiveCell.Row '下端検出 右端 = ActiveCell.Column '右端検出 ' On Error GoTo 0 数式を文字列に変換して格納する フォームを整える 数式を印刷する ' Windows(ブック名).Activate Application.DisplayAlerts = False '確認メッセージを出さない ActiveWorkbook.Close '閉じる Sheets("作業選択").Select '初期画面にもどす Range("H16").Select 'カーソルを定位置へ On Error GoTo 0 'エラー対策を解除 Exit Sub '正常終了 '----------------------------------------------------------------------------------------- エラー処理12: 'エラーが発生した時の入り口 If Err = 1004 Then 'シート保護されているか Resume シート保護を解除してみる End If GoTo エラー処理13 '----------------------------------------------------------------------------------------- シート保護を解除してみる: On Error GoTo 0 On Error GoTo エラー処理13 ActiveSheet.Unprotect 'シート保護解除 GoTo エラー処理12からの戻り口 '----------------------------------------------------------------------------------------- エラー処理13: 'エラーが発生した時の入り口 メッセージ = " [対処例] パスワード違い … ｼｰﾄ保護解除が必要" & Chr(13) & Chr(13) & _ "作業を中止します。原因を取り除いてから、やり直してください。" MsgBox メッセージ, vbCritical, _ "予期せぬエラーが発生しました(13) ... " & Str(Err) & ": " & Error(Err) Stop Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない Close 'ファイルをすべて閉じる Application.Quit 'エクセルを終了する End Sub '----------------------------------------------------------------------------------------- Private Sub 数式を文字列に変換して格納する() 初期状態 = Application.DisplayStatusBar 'ステータスバーの現状を保存する Application.DisplayStatusBar = True 'ステータスバーを表示する 数式エラー = 0 'リセット 縦 = 2 '数式を格納する行 For 列 = 1 To 右端 'A列から右端列まで Application.StatusBar = "数式を調査中・・進行状況 " & 列 & " （" & 右端 & "で編集開始）" 列上 = Application.RoundDown((列 - 1) / 26, 0) If 列上 = 0 Then '列名の上1桁が0なら 列上名 = " " Else 列上名 = Chr(列上 + 64) End If 列名 = 列上名 & Chr((列 - 26 * 列上) + 64) '列名を英字2文字にする If 下端 > 9999 Then '下端の行番号に合わせて 桁数 = 5 '印刷桁数をセットする ElseIf 下端 > 999 Then 桁数 = 4 Else 桁数 = 3 End If For 行 = 1 To 下端 '1行目から下端行まで If IsError(Sheets(シート名).Range(Cells(行, 列), Cells(行, 列))) Then セルの内容がエラー値の場合の処理 縦 = 縦 + 1 Else 調査セル = Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)) 調査セルの数式 = Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)).FormulaR1C1 If Left(調査セルの数式, 1) = "=" Then '1文字目が =なら If 調査セルの数式 <> 調査セル Then '数式を表す文字列が入力されているのでないなら If 選択 = 2 Or 選択 = 3 Then 'A1表示 Sheets(ダミー).Cells(縦, 1) = 列名 & Mid(Str(行), 2, 桁数) Sheets(ダミー).Cells(縦, 2) = "'" + Sheets(シート名).Range(Cells(行, 列), _ Cells(行, 列)).Formula '数式取り出し Else Sheets(ダミー).Cells(縦, 1) = 列名 & Right(" " + Str(行), 5) & "_" & _ Right(" " + Str(列), 桁数) & " " Sheets(ダミー).Cells(縦, 2) = _ "'" + Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)).FormulaR1C1 '数式取り出し End If 縦 = 縦 + 1 End If End If End If Next Next Application.StatusBar = False 'ステータスバーを開放する Application.DisplayStatusBar = False 'ステータスバーを非表示にする Application.DisplayStatusBar = 初期状態 'ステータスバーを初期状態にもどす End Sub '----------------------------------------------------------------------------------------- Private Sub セルの内容がエラー値の場合の処理() 数式エラー = 1 '有:1 調査セル = Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)) Select Case 調査セル Case CVErr(xlErrDiv0) メッセージ = "#DIV/0!エラー：ゼロで除算" Case CVErr(xlErrNA) メッセージ = "#N/Aエラー：使用できる値がない" Case CVErr(xlErrName) メッセージ = "#NAME?エラー：認識できない名前が使われた" Case CVErr(xlErrNull) メッセージ = "#NULL!エラー：指定した2つのセル範囲に共通部分がない" Case CVErr(xlErrNum) メッセージ = "#NUM!エラー：数式の数値に問題がある" Case CVErr(xlErrRef) メッセージ = "#REF!エラー：数式中で無効なセルを参照した" Case CVErr(xlErrValue) メッセージ = "#VALUE!エラー：引数や演算数の種類が正しくない" Case Else メッセージ = "エラー内容不明" End Select ' If 選択 = 2 Or 選択 = 3 Then 'A1表示 Sheets(ダミー).Cells(縦, 1) = 列名 & Mid(Str(行), 2, 桁数) Sheets(ダミー).Cells(縦, 2) = "'" + Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)). _ Formula & " ★" & Str(Err) & ":" & メッセージ 'エラー理由 Else Sheets(ダミー).Cells(縦, 1) = 列名 & Right(" " + Str(行), 5) & "_" & _ Right(" " + Str(列), 桁数) & " " Sheets(ダミー).Cells(縦, 2) = "'" + Sheets(シート名).Range(Cells(行, 列), Cells(行, 列)). _ FormulaR1C1 & " ★" & Str(Err) & ":" & メッセージ 'エラー理由 End If End Sub '----------------------------------------------------------------------------------------- Private Sub フォームを整える() Sheets(ダミー).Select If 選択 = 2 Or 選択 = 3 Then 'A1表示 Cells(1, 1) = "セル" '列見出し Else Cells(1, 1) = "行_列" End If Cells(1, 2) = "数式" Range("A1:B1").HorizontalAlignment = xlCenter '横位置:中央 Columns("A:B").Select 'フォント変更 With Selection.Font .Name = フォント .FontStyle = "標準" .Size = サイズ End With Columns("A:B").EntireColumn.AutoFit '列の幅を自動調整 If 数式エラー = 1 Then '数式エラーが有れば With Worksheets(ダミー).Columns("B") .ColumnWidth = .ColumnWidth * 1.07 End With 'Ｂ列を7%増 End If ' Rows("1:1").Select '１行目 Selection.Insert Shift:=xlDown '行挿入 Range("A1").Value = "[" & ブック名 & "] " & シート名 '分析対象を表示 Rows("1:2").Select 'タイトル行のフォント変更 With Selection.Font .Name = フォント .FontStyle = "標準" .Size = サイズ End With Range("A2:B2").BorderAround Weight:=xlThin '外枠線 Range(Cells(2, 2), Cells(縦, 2)).Borders(xlLeft).Weight = xlHairline '仕切り線 Range(Cells(縦, 1), Cells(縦, 2)).Borders(xlBottom).Weight = xlThin '最下線 ' 用紙のサイズと向きを設定する 左フッター = "&""ＭＳ Ｐ明朝""&8ExcelVBAマクロ 500連発 第2弾" With ActiveSheet.PageSetup .PrintTitleRows = "$1:$2" '行タイトル .CenterHeader = "&""ＭＳ Ｐゴシック,太字""&14数式の一覧" '中央ヘッダー .LeftFooter = 左フッター '左側フッター .CenterFooter = "&P/&N" '中央 〃 .RightFooter = "&""ＭＳ Ｐ明朝,斜体""&8&D &T" '右側 〃 .LeftMargin = Application.CentimetersToPoints(2.5) '左余白 .RightMargin = Application.CentimetersToPoints(1) '右 〃 .TopMargin = Application.CentimetersToPoints(1.7) '上 〃 .BottomMargin = Application.CentimetersToPoints(1.2) '下 〃 .HeaderMargin = Application.CentimetersToPoints(1.3) 'ヘッダー余白 .FooterMargin = Application.CentimetersToPoints(0.8) 'フッター 〃 End With Range("A1").Select End Sub '----------------------------------------------------------------------------------------- Private Sub 用紙のサイズと向きを設定する() If 用紙サイズ = 1 Then ActiveSheet.PageSetup.PaperSize = xlPaperA5 縦幅限界 = 113 '148-25-10=113 ElseIf 用紙サイズ = 3 Then ActiveSheet.PageSetup.PaperSize = xlPaperA3 縦幅限界 = 262 '297-25-10=262 ElseIf 用紙サイズ = 4 Then ActiveSheet.PageSetup.PaperSize = xlPaperB4 縦幅限界 = 222 '257-25-10=222 Else ActiveSheet.PageSetup.PaperSize = xlPaperA4 縦幅限界 = 175 '210-25-10=175 End If ' 列幅 = ((Range("A1").Width + Range("B1").Width)) * 0.35 'mmに換算 If バージョン <> "7.0" Then 列幅 = 列幅 * 1.11 'Excel 95以外 End If If 用紙の向き = 2 Then '縦型 Worksheets(ダミー).PageSetup.Orientation = xlPortrait '縦に設定 ElseIf 用紙の向き = 3 Then '横型 Worksheets(ダミー).PageSetup.Orientation = xlLandscape '横に設定 Else '自動 If 列幅 > 縦幅限界 Then Worksheets(ダミー).PageSetup.Orientation = xlLandscape '横に設定 Else Worksheets(ダミー).PageSetup.Orientation = xlPortrait '縦に設定 End If End If End Sub '----------------------------------------------------------------------------------------- Private Sub 数式を印刷する() If 選択 = 0 Or 選択 = 2 Then ActiveSheet.PrintPreview 'ブレビュー Else If ファイル出力 = 1 Then 'ファイル出力する 数式をファイル出力する Else ActiveWindow.SelectedSheets.PrintOut Copies:=印刷部数 '印刷 End If End If End Sub '----------------------------------------------------------------------------------------- Private Sub 数式をファイル出力する() Sheets("数式印刷用作業シート").Copy '新規ブックへコピーする 新規ブック名 = ActiveWorkbook.Name '新規ブックの名前を覚える Sheets("数式印刷用作業シート").Name = "数式調査結果" 'シート名を変更する Range("A1").ClearContents '一旦クリアする Columns("A:B").EntireColumn.AutoFit '列幅を合わせる Windows(ブック名).Activate '数式調査用のブック Range("A1").Copy Windows(新規ブック名).Activate Range("A1").PasteSpecial Paste:=xlValues '値を貼り付け ' メッセージ = "OKボタンを押してから、ブックを保存してください" タイトル = " . . ファイル出力の準備ができました . ." MsgBox メッセージ, vbInformation, タイトル On Error GoTo 0 Application.Dialogs(xlDialogSaveAs).Show '名前を付けて保存ダイアログを映す ' Application.DisplayAlerts = False '確認メッセージを出さない ActiveWorkbook.Close '閉じる End Sub '========================================================================================= Sub 保存_click() Range("I14").Select 'カーソルを定位置へ タイトル = "保存ボタンが押されました" メッセージ = "上書き保存してよいですか" スタイル = vbYesNo + vbQuestion + vbDefaultButton1 + vbApplicationModal yesno = MsgBox(メッセージ, スタイル, タイトル) If yesno = vbYes Then ActiveWorkbook.Save '上書き保存する End If Sheets("作業選択").Select End Sub '========================================================================================= Sub 終了処理() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close 'このブックを閉じる Workbooks.Close 'すべて閉じる End Sub '========================================================================================= ' V3.2 2000.5.5　　　　　　　　　　　　　　　　　　　　　　　ExcelVBAマクロ 500連発 第2弾 '=========================================================================================