G-Tool2-Main-A01_WS比較用

Excel VBA
2023.10.07

ワークシートの比較ツール

Mainの【ワークシート比較ツール.xlsm】と、結果を書き込む【ワークシート比較結果雛形.xlsm】の
２つのブックを作成します。（Microsoft365 64bit環境推奨）

ツール内容

まず、【Main】のブックから、比較対象のブックアドレス、シート名を取得します。
次に、比較対象シートを指定します。3シートまで比較可能です。
最後に、【実行】ボタン押下で、比較結果が比較結果ブックに展開されます。
（雛形ブックを使用して、比較結果ブックを作成します。）
差異がある場合に、セルの背景色を変更するだけか、差異をコメントに書き出すかを選択できます。
また、差異のあったセルの背景色は青、黄色、緑の3色から選択できます。

実行ブックの作成

  1. 新規ブックを作成します。
  2. 最初に、【ページレイアウト】タブをクリック
  3. まず、左上の【テーマ】を【Office】に設定
  4. 次に、テーマの【フォント】→一番下の【フォントのカスタマイズ】をクリック
  5. 日本語の見出し、本文フォントを【Meiryo UI】に変更
  6. 最後に、【ホーム】タブ→【名前を付けて保存】
    ブック名：ワークシート比較ツール
    【Excel マクロ有効ブック(*.xlsm)】で【保存】します。
    ※ 上記の設定をしない場合、後続の【Main】シート作成の操作を行った際に、列幅が正しく反映されません。

マクロコードの貼り付け

　作成されたMainファイルに標準モジュールを追加します。

  1. 【Alt】＋【F11】キーを押下し、VBE画面を表示
  2. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成
  3. 下記ボックス内をコピーし、標準モジュールに貼り付け
  4. モジュール名を【A01_Public】に変更

　G-Tool2-Main-B01_WS比較用　につづく

　モジュール名：A01_Public
Option Explicit

Public Bln_Err As Boolean
Public IsCall As Boolean
Public ErrProsName As String
Public errMsg As String
Public Twb As Workbook
Public wsMain As Worksheet
Public wsCtrl As Worksheet

Sub SetObject()
    Set Twb = ThisWorkbook
    Set wsMain = Twb.Worksheets("Main")
End Sub

Sub ReSetObject()
    Set Twb = Nothing
    Set wsMain = 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("Main", "A2")
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = False
        .DisplayStatusBar = True
    End With
End Sub

'*****************************************************
'    画面制御セット
'    Call Updating
'*****************************************************
Sub Updating()
    With Application
        .ScreenUpdating = True              '画面描画再開
        .EnableEvents = True                'イベント動作再開
        .Cursor = xlDefault
        .DisplayAlerts = True               '警告再表示
        .StatusBar = False
        '自動計算/手動計算を元の状態に戻す
        Call RestoreCalc("Main", "A2")
        'ステータスバーを表示
        .DisplayStatusBar = True
    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

' +++*******************************************************+++
'    アクティブシートのシェイプを全削除
' +++*******************************************************+++
Public Sub delShapes()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next
End Sub

コメント

タイトルとURLをコピーしました