ワークシートの比較ツール
Mainの【ワークシート比較ツール.xlsm】と、結果を書き込む【ワークシート比較結果雛形.xlsm】の
2つのブックを作成します。(Microsoft365 64bit環境推奨)
比較結果雛形ブックの作成
新規のExcelブック 【ワークシート比較結果雛形.xlsm】を作成します。
- 新規ブックを作成します。
- 最初に、【ページレイアウト】タブをクリック
- まず、左上の【テーマ】を【Office】に設定
- 次に、テーマの【フォント】→一番下の【フォントのカスタマイズ】をクリック
- 日本語の見出し、本文フォントを【Meiryo UI】に変更
- 最後に、【ホーム】タブ→【名前を付けて保存】
ブック名:ワークシート比較結果雛形.xlsm
【Excel マクロ有効ブック(*.xlsm)】で【保存】します。
※ 上記の設定をしない場合、後続の【Main】シート作成の操作を行った際に、列幅が正しく反映されません。
マクロコードの貼り付け
作成された雛形ファイルに標準モジュールを追加します。
- 【Alt】+【F11】キーを押下し、VBE画面を表示
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成
- 下記ボックス内をコピーし、標準モジュールに貼り付け
- モジュール名を【A01_Public】に変更
モジュール名:A01_Public
Option Explicit Public Bln_Err As Boolean Public Twb As Workbook Public wsComp As Worksheet Sub SetObject() Set Twb = ThisWorkbook Set wsComp = Twb.Worksheets("比較結果") End Sub Sub ReSetObject() Set Twb = Nothing Set wsComp = Nothing End Sub '***************************************************** ' 画面制御セット ' Call StopUpdating '***************************************************** Sub StopUpdating() With Application .ScreenUpdating = False '画面描画停止 .EnableEvents = False 'イベント動作停止 .EnableCancelKey = xlErrorHandler '[Esc]キーでエラーをトラップする '========================= '.EnableCancelKey = xlInterrupt '[Esc]キーでVBAの実行を止める(なかなか止まらない) '.EnableCancelKey = xlErrorHandler '[Esc]キーでエラーをトラップする 'On Error GoTo ★★★_Err と使用する '.EnableCancelKey =xlDisabled '[Esc]キーを無効にする '========================= ' .Cursor = xlWait '計算設定取得 Call yourCalc("比較結果", "R2") .DisplayAlerts = False '警告非表示 .DisplayStatusBar = True 'ステータスバーを表示 End With End Sub '***************************************************** ' 画面制御セット ' Call Updating '***************************************************** Sub Updating() With Application .ScreenUpdating = True '画面描画再開 .EnableEvents = True 'イベント動作再開 .Cursor = xlDefault .DisplayAlerts = True '警告再表示 '計算設定を戻す Call RestoreCalc("比較結果", "R2") .StatusBar = False 'ステータスバーを表示 End With End Sub '+++***********************************************+++ ' 自動/手動計算設定取得 ' Call yourCalc("Main","A2") '+++***********************************************+++ Public Function yourCalc(shtName As String, strRng As String) 'エラーを無視 On Error Resume Next With ThisWorkbook.Worksheets(shtName) With .Range(strRng) .Font.Color = .Interior.Color If Application.Calculation = xlCalculationAutomatic Then .Value = 1 ElseIf Application.Calculation = xlCalculationManual Then .Value = 2 ElseIf Application.Calculation = xlCalculationSemiautomatic Then .Value = 3 End If End With End With 'エラー制御を戻す On Error GoTo 0 End Function '+++***********************************************+++ ' 自動/手動計算を最初の設定に戻す ' Call RestoreCalc("Main","A2") '+++***********************************************+++ Public Function RestoreCalc(shtName As String, strRng As String) 'エラーを無視 On Error Resume Next With ThisWorkbook.Worksheets(shtName) With .Range(strRng) .Font.Color = .Interior.Color If .Value = 1 Then Application.Calculation = xlCalculationAutomatic ElseIf .Value = 2 Then Application.Calculation = xlCalculationManual ElseIf .Value = 3 Then Application.Calculation = xlCalculationSemiautomatic End If End With End With 'エラー制御を戻す On Error GoTo 0 End Function '----------------------------------------------------- ' ステータスバーを使用する ' Call showStatus(msg) '----------------------------------------------------- Public Sub showStatus(ByVal MSG As String) 'エラーを無視 On Error Resume Next ThisWorkbook.Activate ActiveWindow.WindowState = xlMaximized Application.StatusBar = MSG DoEvents 'エラー制御を戻す On Error GoTo 0 End Sub '----------------------------------------------------- ' ステータスバーをClear ' Call clrStatus '----------------------------------------------------- Public Sub clrStatus() 'エラーを無視 On Error Resume Next DoEvents Application.StatusBar = False 'エラー制御を戻す On Error GoTo 0 End Sub '----------------------------------------------------- ' OSに制御を渡す ' Call exeBreak '----------------------------------------------------- Public Sub exeBreak() 'エラーを無視 On Error Resume Next DoEvents 'エラー制御を戻す On Error GoTo 0 End Sub '+++***********************************************+++ ' シート検出 ' Call IsShtOwb(shtName, OtrwbName) '+++***********************************************+++ Public Function IsShtOwb(shtName As String, wbName As String) As Boolean Dim sht As Worksheet Dim Otrwb As Workbook IsShtOwb = False Set Otrwb = Workbooks(wbName) For Each sht In Otrwb.Worksheets If sht.Name = shtName Then IsShtOwb= True Set Otrwb = Nothing Exit Function End If Next sht 'エラーを無視 On Error Resume Next Set Otrwb = Nothing 'エラー制御を戻す On Error GoTo 0 End Function ' +++*******************************************************+++ ' アクティブシートのシェイプを全削除 ' +++*******************************************************+++ Public Sub delShapes() Dim shp As Shape For Each shp In ActiveSheet.Shapes shp.Delete Next End Sub
コメント