G-Tool2-Main-M01_WS比較用

Excel VBA
2023.10.07

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

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

マクロコードの貼り付け

　作成されたMainファイルに標準モジュールを追加します。
　１. 【Alt】＋【F11】キーを押下し、VBE画面を表示
　２. 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成
　３. 下記ボックス内をコピーし、標準モジュールに貼り付け
　４．モジュール名を【M01_Main】に変更

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

　モジュール名：M01_Main
Option Explicit
'====================================================
'     【Main】シート 【比較】ボタン押下で作動
'====================================================
Sub CompSheets()

    Dim Ans As Integer
    
    Dim formatFile As String
    Dim formatFName As String
    Dim dstFolder As String
    Dim compFile1 As String
    Dim compFile2 As String
    Dim compFileName1 As String
    Dim compFileName2 As String
    Dim compFName1 As String
    Dim compFName2 As String
    Dim strCompSht1 As String
    Dim strCompSht2 As String
    Dim NewPath As String
    Dim dstFLen As Long
    Dim nowFLen As Long
    Dim MaxLen As Long
    Dim cnt1 As Long
    Dim cnt2 As Long
    Dim errMsg As String
    Dim MSG As String
    Dim hcAry As Variant
    Dim tHC As String               'tempHeadCharacter: A, B, C
    
    Dim tempName1 As String
    Dim tempName2 As String
    Dim nameHead As String
    Dim shtName As String
    Dim shtName1 As String
    Dim shtName2 As String
    Dim buf As String
    Dim buf1 As String
    Dim buf2 As String
    Dim buf3 As String
    Dim buf4 As String

    Dim tmp1 As Variant
    Dim tmp2 As Variant
    Dim tabColor As Variant
    Dim dstShtAry As Variant
    Dim dstShtAryl As Variant
    Dim dstShtAry2 As Variant
    Dim myColor As Long
    
    Dim CompBook1 As Workbook
    Dim CompBook2 As Workbook
    Dim formatBook As Workbook
    Dim dstBook As Workbook
    Dim dstfileName As String
    Dim dstBookName As String
    Dim orgSht1 As Worksheet
    Dim orgSht2 As Worksheet
    Dim dstSht1 As Worksheet
    Dim dstSht2 As Worksheet
    Dim dstSht3 As Worksheet
    Dim dstSht4 As Worksheet
    Dim orgSht As Worksheet
    Dim wb As Workbook
    
    Dim diffColor As Long
    Dim strPrefix As String
    Dim strTemp As String
    Dim strVisi As String
    
    '【比較結果】ブック
    Dim wsComp As Worksheet         '【比較結果】シート
    Dim wsFst As Worksheet
    Dim wsScd As Worksheet
    Dim wsDiff As Worksheet
    Dim wsRatio As Worksheet
    
    Dim fstMaxRow As Long           '最終行
    Dim fstMaxCol As Long           '最終列
    Dim scdMaxRow As Long           '最終行
    Dim scdMaxCol As Long           '最終列
    
    Dim preAry1() As Variant
    Dim preAry2() As Variant
    Dim fstAry() As Variant
    Dim sedAry() As Variant
    Dim orgMemoAry() As Variant
    Dim diffAry() As Variant
    Dim ratioAry() As Variant
    Dim diffMemoAry() As Variant
    Dim compAry() As Variant
    Dim rsltAry() As Variant
    Dim wdwZoom() As Variant

    Dim strFst As String
    Dim strSed As String
    Dim strDiff As String
    Dim strRatio As String
    Dim tmpMemo As String
    Dim diffMemo As String
    Dim cFormat As String
    
    Dim dblFst As Double
    Dim dblScd As Double
    Dim dblDiff As Double
    Dim dblRatio As Double
    Dim dblZoom As Double
    
    Dim chkCnt As Double            '比較検証セル数
    Dim misMCnt As Double           '不一致(ミスマッチ）件数
    Dim misCnt As Long              '不一致（ミスマッチ）表示件数（1,000件まで）
    Dim addNo As Long

    Dim i As Long
    Dim ii As Long
    Dim j As Long
    Dim x As Long
    Dim xx As Long
    Dim xRow As Long            '1列の最終行
    Dim MaxRow As Long          '最終行
    Dim MaxCol As Long          '最終列
    Dim CopyRng As Range
    Dim shp As Shape
    Dim sttTime As Double
    Dim ngStr As Variant
    
    Dim makeDiffSht As Boolean
    Dim addPrefix As Boolean
    Dim IsOpen As Boolean
    Dim IsSht1 As Boolean
    Dim IsSht2 As Boolean
    Dim notComp As Boolean
    Dim nmlTmn As Boolean       '正常終アフラグ：normal Termination

    Bln_Err = False
    nmlTmn = False
    
    ErrProsName = "CompSheets"
    On Error GoTo CompSheets_Err
    
    IsCall = False              '初期値

    '処理開始確認
    Ans = MsgBox("ファイルをワークシート毎に比較し、結果を作成します。" & _
            vbCrLf & vbCrLf & _
            "ツール実行中は、ラァイルのコピー＆ペースト作業を行わないでください。" _
            & vbCrLf & "処理を開始します。", _
            vbQuestion + vbOKCancel + vbDefaultButton1, "【ワークシート比較ツール】")
    
    Select Case Ans
        Case vbOK
            '処理続行
        Case vbCancel
            MsgBox "キャンセルしました。"
            Exit Sub
    End Select

    Call SetObject
    
    With wsMain
    
        .Range("C12").Value = "比較開始日時：" & Now
        Sleep 300
        
        'ステータスバーに状況表示
        Call showStatus("比較処理中")
        Call StopUpdating
        
        '比較結果雛形ファイル
        formatFile = .Range("E4").Value
        formatFile = Replace(formatFile, "/", "\")
        formatFName = Mid(formatFile, InStrRev(formatFile, "*") + 1)
        '保存フォルダ
        dstFolder = Range("E5").Value
        '比較結果ファイル名
        dstfileName = Range("E6").Value
        
        '比較ファイル① パス＆ワークシート
        compFile1 = .Range("E9").Value
        strCompSht1 = .Range("G9").Value
        '比較ファイル② パス＆ワークシート
        compFile2 = .Range("E10").Value
        strCompSht2 = .Range("G10").Value
        
        makeDiffSht = False
        If .OptionButtons("Option 作成する").Value = xlOn Then
            makeDiffSht = True
        ElseIf .OptionButtons("Option 作成しない").Value = xlOn Then
            makeDiffSht = False
        End If
        
    End With

'----------------------------------------------------------------------------
'     入カチェック
'----------------------------------------------------------------------------
    
    'ステータスバーに状況表示
    Call showStatus("(2) 入力チェック中")
    '空白､存在チェック
    errMsg = ""     '初期値
    If formatFile = "" Then
        errMsg = "比較結果雛形ファイルを指定してください｡"
        GoTo InputCheck_Err
    Else
        If Dir(formatFile, vbNormal) = "" Then
            errMsg = "比較結果雛形ファイルパスを確認してください。"
            GoTo InputCheck_Err
        End If
    End If
    
    If dstFolder = "" Then
        errMsg = "保存先フォルダを指定してください"
        GoTo InputCheck_Err
    Else
        If Right(dstFolder, 1) = "\" Then
            dstFolder = Trim(Left(dstFolder, Len(dstFolder) - 1))
        End If
        
        dstFLen = Len(dstFolder)
        
        If Dir(dstFolder, vbDirectory) = "" Then
            errMsg = "保存先フォルダを確認してください。"
            GoTo InputCheck_Err
        End If
      
    End If
    
    If dstfileName = "" Then
        '比較ファイル①から結果ファイル名を作成
    Else
        'ユーザ指定がある場合、名前チェック
        'フルパス：218文字を超えると保存できない(Windowsは255文字）
        nowFLen = dstFLen + Len(dstfileName) + 21
        If nowFLen > 218 Then
            MaxLen = 218 - dstFLen - 21
            nowFLen = Len(dstfileName)
            errMsg = "【比較結果ファイル名】文字数が長すぎます。" & vbCr & _
            "現在:" & Len(dstfileName) & " 文字 " & MaxLen & " 文字までに" & vbCr & _
            "変更してください。"
            GoTo InputCheck_Err
        End If
        
        ngStr = Array("\", "/", """""", "<", ">", "?", "[", "]", ":", "|", "*")
        For i = 0 To UBound(ngStr)
            buf = ngStr(i)
            If InStr(dstfileName, buf) > 0 Then
                errMsg = "使用不可文字【比較結果ファイル名】：" & buf
                Exit For
            End If
            If errMsg <> "" Then
                GoTo InputCheck_Err
            End If
        Next i
    End If
    If compFile1 = "" Then
        errMsg = "比較ファイル①を指定してください。"
        GoTo InputCheck_Err
    Else
        If Dir(compFile1, vbNormal) = "" Then
            errMsg = "比較ファイル①を確認してください｡"
            GoTo InputCheck_Err
        Else
            compFile1 = Replace(compFile1, "/", "\")
            compFName1 = Mid(compFile1, InStrRev(compFile1, "\") + 1)
        End If
    End If
    
    If compFile2 = "" Then
        errMsg = "比較ファイル②を指定してください。"
        GoTo InputCheck_Err
    Else
        If Dir(compFile2, vbNormal) = "" Then
            errMsg = "比較ファイル②を確認してください｡"
            GoTo InputCheck_Err
        Else
            compFile2 = Replace(compFile2, "/", "\")
            compFName2 = Mid(compFile2, InStrRev(compFile2, "\") + 1)
            
            If compFile1 = compFile2 Then
                errMsg = "比較ファイル①,②は同じファイルです。"
                GoTo InputCheck_Err
            End If
        End If
    End If
    
    If strCompSht1 = "" Then
       errMsg = "比較ファイル①ワークシートを指定してください。"
       GoTo InputCheck_Err
    Else
        'vbCrをvbLfに変換  ''本当は不要
        strCompSht1 = Replace(strCompSht1, vbCr, vbLf)
        tmp1 = Split(strCompSht1, vbLf)
    End If
    If strCompSht2 = "" Then
        errMsg = "比較ファイル②ワークシートを指定してください。"
        GoTo InputCheck_Err
    Else
        'vbCrをvbLfに変換    ''本当は不要
        strCompSht2 = Replace(strCompSht2, vbCr, vbLf)
        tmp2 = Split(strCompSht2, vbLf)
    End If
    
    If UBound(tmp1) <> UBound(tmp2) Then
        errMsg = "比較シート数が異なります｡確認してください｡"
        GoTo InputCheck_Err
    End If
    
    
    '↑↑↑ 入カチェックここまで ↑↑↑
'----------------------------------------------------------------------------
    dstFolder = dstFolder & "\"
    If dstfileName = "" Then
        'ユーザ指定がない場合
        NewPath = dstFolder & "比較_" & compFName1 & Format(Now, "_YYMMDD _hhmm") & ".xlsm"
    Else
        'ユーザ指定がある場合
         NewPath = dstFolder & "比較_" & dstfileName & Format(Now, "_YYMMDD _hhmm") & ".xlsm"
    End If
    
    dstBookName = Mid(NewPath, InStrRev(NewPath, "\") + 1)
    
    'ステータスバーに状況表示
    Call showStatus("(3）転記処理中")
    
    '比較結果雛形ファイルについて
    '開かれているファイルかどうか確認
    IsOpen = False
    For Each wb In Workbooks
        If wb.Name = formatFName Then
            If wb.FullName = formatFile Then
                IsOpen = True
                Set formatBook = wb
                Exit For
            Else
                wb.Close
            End If
        End If
    Next wb
    
    If IsOpen Then
        formatBook.Saves Filename:=NewPath
        Set dstBook = Workbooks(formatFName)
        Set formatBook = Nothing
    Else
        'フォーマットファイルをコピーし､結果ファイルを作成
        FileCopy formatFile, NewPath
        '読み取りではなく、リンク更新なしで開く
        Set dstBook = Workbooks.Open(NewPath, ReadOnly:=False, UpdateLinks:=0)
        If Err.Number > 0 Then
            MsgBox "Open時エラー: 比較結果ファイルが開けませんでした｡" & vbCr & _
                    "確認してください｡処理を終了します｡", vbExclamation
            Err.Clear
            GoTo CompSheets_Exit
        End If
    End If

    '【比較結果】ファイルにおいて
    With dstBook
        If IsShtOwb("比較結果", dstBookName) = False Then
            MsgBox "比較結果ファイルに比較結果シートが存在しません。" & vbCr & _
                    "確認してください。処理を終了します。", vbExclamation
            GoTo CompSheets_Exit
        End If
    End With
    
'----------------------------------------------------------------------------
    hcAry = Array("a", "b", "с")
    tabColor = Array(rgbMidnightBlue, rgbRoyalBlue, rgbDarkTurquoise)

    If compFName1 = compFName2 Then
    '【比較ファイル①】ファイル名と【比較ファイル②】 ファイル名が同じ場合
        For Each wb In Workbooks
            If wb.Name = compFName2 Then
                If wb.FullName = compFile2 Then
                    '【比較ファイル②】を開いていたら閉じる
                    wb.Close
                    Exit For
                End If
            End If
        Next wb
    End If
    
    '【比較ファイル①】ファイルについて
    '開かれているファイルかどうか確認
    IsOpen = False
    For Each wb In Workbooks
        If wb.Name = compFName1 Then
            If wb.FullName = compFile1 Then
                IsOpen = True
                Set CompBook1 = wb
                Exit For
            Else
                '比較ファイル①ではない
                '同名ファイルは閉じる
                wb.Close
             End If
        End If
    Next wb

    '【比較ファイルの】のシートを【比較結果】ファイルにコピー
    '読み取り、リンク更新なしで開く
    If IsOpen = False Then
        Set CompBook1 = Workbooks.Open(Filename:=compFile1, ReadOnly:=True, UpdateLinks:=0)
    End If
    '【比較ファイル①】において
    With CompBook1
        ReDim wdwZoom(UBound(tmp1))
        For x = 0 To UBound(tmp1)
       
            shtName1 = CStr(tmp1(x))
            myColor = tabColor(x)
            tHC = CStr(hcAry(x))
            tempName1 = Left(shtName1, 24)
    
            'シートが存在するか確認
            If IsShtOwb(shtName1, compFName1) Then
            
                '存在する場合
                Set orgSht1 = .Sheets(shtName1)
                orgSht1.Copy After:=dstBook.Worksheets(dstBook.Worksheets.Count)
                Sleep 200
                Application.CutCopyMode = False
                Set dstSht1 = ActiveSheet
                wdwZoom(x) = ActiveWindow.Zoom
                buf1 = tHC & "①_" & tempName1
                
                With dstSht1
                    .Name = buf1
                    .Tab.Color = myColor
                    '値貼り付け
                    With .UsedRange
                        .Value = .Value
                    End With
                End With
                '指定シートの余分な余白やマクロボタンを削除等を行う
                Call cutShtExtra(buf1, dstBookName)
               
                Set orgSht1 = Nothing
            Else
                
                '存在しない場合
                With dstBook
                    Worksheets.Add After:=.Worksheets(.Worksheets.Count)
                    Set dstSht1 = ActiveSheet
                    buf1 = tHC & "①_" & tempName1
                    dstSht1.Name = buf1
                    dstSht1.Tab.Color = myColor
                    dstSht1.Range("A1").Value = "【比較ファイル①】に対象シートなし"
                End With
            End If
            
            Set dstSht1 = Nothing

        Next x
        
        '保存せずに閉じる
        .Close False
    End With
    Set CompBook1 = Nothing
    
    '【比較ファイル②】ファイルについて
    '開かれているファイルかどうか確認
    IsOpen = False
    For Each wb In Workbooks
        If wb.Name = compFName2 Then
            If wb.FullName = compFile2 Then
                IsOpen = True
                Set CompBook2 = wb
                Exit For
            Else
                '比較ファイル②ではない
                '同名ファイルは閉じる
                wb.Close
            End If
        End If
    Next wb
    
    '読み取り、リンク更新なしで開く
    If IsOpen = False Then
        Set CompBook2 = Workbooks.Open(Filename:=compFile2, ReadOnly:=True, UpdateLinks:=0)
    End If
    With CompBook2

        For x = 0 To UBound(tmp2)
        
            shtName2 = CStr(tmp2(x))
            myColor = tabColor(x)
            tHC = CStr(hcAry(x))
            tempName2 = Left(shtName2, 24)
            
            buf2 = tHC & "②_" & tempName2
            buf3 = tHC & "③_" & tempName2 & "（差分）"
            buf4 = tHC & "④_" & tempName2 & "（比率）"
            
            '【tHC & "①_" ～】シートの位置を確認
            nameHead = tHC & "①_"
            If IsShtNo(nameHead, dstBook.Name) > 0 Then
                xx = IsShtNo(nameHead, dstBook.Name)
            End If
            
            'シートが存在するか確認
            If IsShtOwb(shtName2, compFName2) Then
                
                '存在する場合
                Set orgSht2 = .Sheets(shtName2)
                orgSht2.Copy After:=dstBook.Worksheets(xx)
                ActiveWindow.Zoom = wdwZoom(x)
                If makeDiffSht Then
                    orgSht2.Copy After:=dstBook.Worksheets(xx)
                    ActiveWindow.Zoom = wdwZoom(x)
                    orgSht2.Copy After:=dstBook.Worksheets(xx)
                    ActiveWindow.Zoom = wdwZoom(x)
                End If
                Sleep 100
                Application.CutCopyMode = False
                Set dstSht2 = dstBook.Worksheets(xx + 1)
                
                With dstSht2
                    .Name = buf2
                    .Tab.Color = myColor
                    '値貼り付け
                    With .UsedRange
                        .Value = .Value
                    End With
                End With
                '指定シートの余分な余白やマクロボタンを削除 等を行う
                Call cutShtExtra(buf2, dstBookName)
                    
                If makeDiffSht Then
                
                    Set dstSht3 = Worksheets(xx + 2)
                    
                    With dstSht3
                        .Name = buf3
                        .Tab.Color = myColor
                        '値貼り付け
                        With .UsedRange
                            .Value = .Value
                        End With
                    End With
                    '指定シートの余分な余白やマクロボタンを削除 等を行う
                    Call cutShtExtra(buf3, dstBookName)
                    Set dstSht4 = Worksheets(xx + 3)

                    With dstSht4
                        .Name = buf4
                        .Tab.Color = myColor
                        '値貼り付け
                        With .UsedRange
                            .Value = .Value
                        End With
                    End With
                    '指定シートの余分な余白やマクロボタンを削除 等を行う
                    Call cutShtExtra(buf4, dstBookName)
                End If
                
            Else
                '存在しない場合
                With dstBook
                    Worksheets.Add After:=.Worksheets(xx)
                    Set dstSht2 = ActiveSheet
                    buf2 = tHC & "②_" & tempName2
                    dstSht2.Name = buf2
                    dstSht2.Tab.Color = myColor
                    dstSht2.Range("A1").Value = "【比較ファイル②】に対象シートなし"
                End With
            End If
                
            'エラーを無視
            On Error Resume Next
            Set orgSht2 = Nothing
            Set dstSht2 = Nothing
            Set dstSht3 = Nothing
            Set dstSht4 = Nothing
            'エラー制御を戻す
            On Error GoTo 0
            
        Next x
        '保存せずに閉じる
        .Close False
    End With
    Set CompBook2 = Nothing
        
'----------------------------------------------------------------------------
'     比較処理
'----------------------------------------------------------------------------
    'ステータスバーに状況表示
    Call showStatus("(4) 比較処理中")
    With wsMain
        '差異あり: 背景色指定
        If .OptionButtons("Option 青").Value = xlOn Then
            '青
            diffColor = RGB(0, 176, 240)
        ElseIf .OptionButtons("Option 緑").Value = xlOn Then
            '緑
            diffColor = RGB(0, 255, 0)
        ElseIf .OptionButtons("Option 黄").Value = xlOn Then
            '黄
            diffColor = RGB(255, 255, 0)
        End If
        
    End With

    With dstBook
        Call BreakLink
        Set wsComp = .Worksheets("比較結果")
        With wsComp
            .Range("E8").Value = compFile1
            .Range("L8").Value = FileDateTime(compFile1)
            .Range("E10").Value = compFile2
            .Range("L10").Value = FileDateTime(compFile2)
        End With

        'いったん保存：UsedRangeを反映するため
        .Save
        strPrefix = "'"
        For x = 0 To UBound(tmp1)

            shtName1 = CStr(tmp1(x))
            shtName2 = CStr(tmp2(x))
            '【比較結果】シート
            With wsComp
                addNo = 6 * x
                .Cells(14, 5 + addNo).Value = shtName1
                .Cells(14, 6 + addNo).Value = shtName2
            End With
            Call showStatus("(4) 比較処理中ワークシート：" & shtName1)
            IsSht1 = True
            IsSht2 = True
            tHC = CStr(hcAry(x))
            nameHead = tHC & "①_"
            If IsShtNo(nameHead, dstBook.Name) > 0 Then
                xx = IsShtNo(nameHead, dstBook.Name)
                Set wsFst = .Worksheets(xx)
            End If
            If InStr(wsFst.Range("A1").Value, "に対象シートなし") > 0 Then
                IsSht1 = False
            End If
            
            nameHead = tHC & "②_"
            If IsShtNo(nameHead, dstBook.Name) > 0 Then
                xx = IsShtNo(nameHead, dstBook.Name)
                Set wsScd = .Worksheets(xx)
            End If
            If InStr(wsScd.Range("A1").Value, "に対象シートなし") > 0 Then
                IsSht2 = False
            End If
            If makeDiffSht Then
                nameHead = tHC & "③_"
                If IsShtNo(nameHead, dstBook.Name) > 0 Then
                    xx = IsShtNo(nameHead, dstBook.Name)
                    Set wsDiff = .Worksheets(xx)
                End If
                nameHead = tHC & "④_"
                If IsShtNo(nameHead, dstBook.Name) > 0 Then
                    xx = IsShtNo(nameHead, dstBook.Name)
                    Set wsRatio = .Worksheets(xx)
                End If
            End If

            If IsSht1 = False Or IsSht2 = False Then
                '【比較結果】シート
                With wsComp
                    If IsSht1 = False Then
                        .Cells(14, 5 + addNo).Value = "なし:" & shtName1
                        .Cells(14, 5 + addNo).Interior.Color = RGB(255, 255, 102)
                    End If
                    If IsSht1 = False Then
                        .Cells(14, 6 + addNo).Value = "なし:" & shtName2
                        .Cells(14, 6 + addNo).Interior.Color = RGB(255, 255, 102)
                    End If
                    .Cells(12, 6 + addNo).Value = "対象シートなし"
                    .Cells(12, 6 + addNo).Interior.Color = RGB(255, 255, 102)
                    .Cells(13, 6 + addNo).Value = ""
                    .Cells(13, 6 + addNo).Interior.Color = RGB(255, 255, 102)
                End With
                GoTo NextX
                
            End If
            
            With wsFst
                '使用済み範囲の最終行、最終列
                With .UsedRange
                    fstMaxRow = .Rows(.Rows.Count).Row
                    fstMaxCol = .Columns(.Columns.Count).Column
                End With
            End With
            With wsScd
                '使用済み範囲の最終行､最終列
                With .UsedRange
                    scdMaxRow = .Rows(.Rows.Count).Row
                    scdMaxCol = .Columns(.Columns.Count).Column
                End With
            End With
            
            MaxRow = WorksheetFunction.Max(fstMaxRow, scdMaxRow)
            MaxCol = WorksheetFunction.Max(fstMaxCol, scdMaxCol)

            If MaxRow = 1 And MaxCol = 1 Then
                '【比較結果】シート
                With wsComp
                    addNo = 6 * x
                    .Cells(12, 6 + addNo).Value = "対象データなし"
                    .Cells(13, 6 + addNo).Value = 0
                End With
                GoTo NextX

            End If

            With wsFst
            
                ReDim preAry1(1 To MaxRow, 1 To MaxCol)
                ReDim fstAry(1 To MaxRow, 1 To MaxCol)
                
                preAry1 = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol))
                fstAry = Range(.Cells(1, 1), .Cells(MaxRow, MaxCol))
                
                For i = 1 To MaxRow
                    For j = 1 To MaxCol
                        addPrefix = False
                        strTemp = ""
                        If .Cells(i, j).PrefixCharacter = strPrefix Then
                            If Left(preAry1(i, j), 1) <> strPrefix Then
                                addPrefix = True
                                strTemp = strPrefix & CStr(preAry1(i, j))
                            Else
                                strTemp = CStr(preAry1(i, j))
                            End If
                        Else
                           strTemp = CStr(preAry1(i, j))
                        End If
                        If IsDate(strTemp) Then
                            strTemp = "'" & strTemp
                        End If
                        strVisi = .Cells(i, j).Text
                        If InStr(strVisi, "年度") > 0 Then
                            If addPrefix Then
                                strTemp = strPrefix & strVisi
                            Else
                                strTemp = strVisi
                            End If
                        End If
                        strTemp = Replace(strTemp, vbCrLf, "")
                        fstAry(i, j) = strTemp
                    Next j
                    
                Next i
                Erase preAry1
            End With
            
            With wsScd
                
                ReDim preAry2(1 To MaxRow, 1 To MaxCol)
                ReDim scdAry(1 To MaxRow, 1 To MaxCol)
                
                preAry2 = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol))
                scdAry = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol))
                orgMemoAry = .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol))

                For i = 1 To MaxRow
                    For j = 1 To MaxCol
                        addPrefix = False
                        strTemp = ""
                        If .Cells(i, j).PrefixCharacter = strPrefix Then
                            If Left(preAry2(i, j), 1) <> strPrefix Then
                                addPrefix = True
                                strTemp = strPrefix & CStr(preAry2(i, j))
                            Else
                                strTemp = CStr(preAry2(i, j))
                            End If
                        Else
                            strTemp = CStr(preAry2(i, j))
                        End If
                        If IsDate(strTemp) Then
                            strTemp = "'" & strTemp
                        End If
                        strVisi = .Cells(i, j).Text
                        If InStr(strVisi, "年度") Then
                            If addPrefix Then
                                strTemp = strPrefix & strVisi
                            Else
                                strTemp = strVisi
                            End If
                        End If
                        strTemp = Replace(strTemp, vbCrLf, "")
                        scdAry(i, j) = strTemp
'========================================================================================
                        With .Cells(i, j)
                            If TypeName(.Comment) = "Nothing" Then
                                'セルにコメントなし
                                tmpMemo = ""
                            Else
                                'セルにコメントあり
                                tmpMemo = .Comment.Text
                            End If
                            orgMemoAry(i, j) = tmpMemo
                        End With
                    Next j
                    
                Next i
                
                ReDim diffAry(1 To MaxRow, 1 To MaxCol)
                ReDim ratioAry(1 To MaxRow, 1 To MaxCol)
                ReDim diffMemoAry(1 To MaxRow, 1 To MaxCol)
'*** 比較 ****************************************************
                misMCnt = 0
                misCnt = 0
                chkCnt = MaxRow * MaxCol
                cFormat = "#,##0.0############;-#,##0.0################;0;@"
                For i = 1 To MaxRow
                    For j = 1 To MaxCol
                        strFst = CStr(fstAry(i, j))
                        strSed = CStr(scdAry(i, j))
                        strRatio = ""
                        diffMemo = ""

                        If strFst <> strSed Then
                            '不一致の場合
                            misMCnt = misMCnt + 1
                            
                            If misMCnt <= 1000 Then
                                misCnt = misCnt + 1
                                ReDim Preserve compAry(1 To 5, 1 To misCnt)
                                
                                compAry(1, misCnt) = misMCnt
                                compAry(2, misCnt) = .Cells(i, j).Address(False, False)
                                compAry(3, misCnt) = strFst
                                compAry(4, misCnt) = strSed
                                compAry(5, misCnt) = " "
                            End If
                            
                            If IsDate(strFst) = True And IsDate(strSed) = True Then
                                '両方 日付の場合
                                dblDiff = 0
                                dblRatio = 0
                            
                                diffMemo = "前値：" & fstAry(i, j) & vbCrLf & _
                                           "今値：" & scdAry(i, j)
                           
                            ElseIf IsNumeric(strFst) = True And IsNumeric(strSed) = True Then
                                '両方 数値の場合
                                dblFst = CDbl(fstAry(i, j))
                                dblScd = CDbl(scdAry(i, j))
                                
                                If makeDiffSht Then
                                    dblDiff = dblScd - dblFst
                                    diffMemo = "前値：" & Format(fstAry(i, j), cFormat) & vbCrLf & _
                                               "今値：" & Format(scdAry(i, j), cFormat) & vbCrLf & _
                                               "差分：" & Format(dblDiff, cFormat)
                                Else
                                    diffMemo = "前値：" & fstAry(i, i) & vbCrLf & _
                                               "今値：" & scdAry(i, j)
    
                                End If
                                If dblFst = 0 Then
                                    If makeDiffSht Then
                                        strRatio = "ー"
                                        diffMemo = diffMemo & vbCrLf & _
                                                   "比率:" & strRatio
                                    End If
                                Else
                                    If makeDiffSht Then
                                        dblRatio = dblScd / dblFst
                                        diffMemo = diffMemo & vbCrLf & _
                                                   "比率:" & Format(dblRatio, "0.0%")
                                        wsRatio.Cells(i, j).NumberFormatLocal = "0.0%;[赤]-0.0%;"
                                    End If
                                End If
                                    
                            Else
                                'それ以外
                                dblDiff = 0
                                dblRatio = 0
                                
                                diffMemo = "前値：" & Format(fstAry(i, j), cFormat) & vbCrLf & _
                                           "今値：" & Format(scdAry(i, j), cFormat)
                            End If
                            wsScd.Cells(i, j).Interior.Color = diffColor
                            If makeDiffSht Then
                                wsDiff.Cells(i, j).Interior.Color = diffColor
                                wsRatio.Cells(i, j).Interior.Color = diffColor
                            End If
                        Else
                            '一致の場合
                            dblDiff = 0
                            dblRatio = 0
                        End If
                        If dblDiff = 0 Then
                            diffAry(i, j) = preAry2(i, j)
                        Else
                            diffAry(i, j) = dblDiff
                        End If

                        If dblRatio = 0 Then
                            ratioAry(i, j) = preAry2(i, j)
                        ElseIf strRatio = "ー" Then
                            ratioAry(i, j) = strRatio
                        Else
                            ratioAry(i, j) = dblRatio
                        End If
                        
                        If orgMemoAry(i, j) = "" Then
                            If diffMemo = "" Then
                                diffMemoAry(i, j) = ""
                            Else
                                diffMemoAry(i, j) = diffMemo
                            End If
                        Else
                            If diffMemo = "" Then
                                diffMemoAry(i, j) = ""
                            Else
                                diffMemoAry(i, j) = orgMemoAry(i, j) & vbCrLf & _
                                "'" & WorksheetFunction.Rept("=", 15) & vbCrLf & _
                                diffMemo
                            End If
                        End If

                    Next j
                Next i
            End With
            '【比較結果】シート
            With wsComp
                .Cells(12, 6 + addNo).Value = chkCnt
                .Cells(13, 6 + addNo).Value = misMCnt
                If misMCnt > 0 Then
                    .Cells(19, 3 + addNo).Resize(misCnt, 5) = _
                        WorksheetFunction.Transpose(compAry)
                End If
            End With
            With wsScd
                '記入されたコメント削除（なくてもエラーは出ない）
                .Cells.ClearComments
                'コメント記入
                For i = 1 To MaxRow
                    For j = 1 To MaxCol
                        If diffMemoAry(i, j) <> "" Then
                            .Cells(i, j).AddComment diffMemoAry(i, j)
                            .Cells(i, j).Comment.Shape.TextFrame.AutoSize = True
                        End If
                    Next j
                Next i
            End With
            If makeDiffSht Then
                With wsDiff
                    .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value = diffAry
                End With
                With wsRatio
                    .Range(.Cells(1, 1), .Cells(MaxRow, MaxCol)).Value = ratioAry
                End With
            End If
            Erase fstAry
            Erase scdAry
            Erase compAry
            Erase diffAry
            Erase ratioAry
NextX:
'**↑比較 ↑ ****************************************************************************
        Next x
        'エラーを無視
        On Error Resume Next
        Application.GoTo Reference:=.Range("Al"), Scroll:=True
        
        With wsComp
            .Activate
            .Range("Q2") = Now
            Application.GoTo Reference:=.Range("Al"), Scroll:=True
        End With
        'エラー制御を戻す
        On Error GoTo 0
        ActiveWindow.WindowState = xlMaximized
        .Save
    End With

'↑↑↑ シート比較ここまで ↑↑↑
'----------------------------------------------------------------------------------------
    Twb.Activate
    With wsMain
        .Range("C11").Value = .Range("C11").Value & vbCrLf & "比較終了日時：" & Now
    End With
        
    '============================================
    nmlTmn = True
    'End If
CompSheets_Exit:
    'エラーを無視
    On Error Resume Next

    If nmlTmn Then
        MsgBox "比較処理完了♪"
        Windows(ThisWorkbook.Name).WindowState = xlMinimized
        ActiveWindow.WindowState = xlMaximized
    Else
        wsMain.Range("C12") = ""
        If errMsg = "" Then
            MsgBox "比較処理未完了", vbExclamation
        End If
    End If
    Call ReSetObject
    Call Updating
　　'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
    
CompSheets_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
    Err.Description & vbCr & _
    "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear       'エラー情報クリア
    GoTo CompSheets_Exit
    
InputCheck_Err:
    '入カチェックエラー時
    If errMsg <> "" Then
        MsgBox errMsg & vbCr & _
            "処理を終了します。", vbExclamation, "入力チェック_エラー "
        Err.Clear       'エラー情報クリア
        GoTo CompSheets_Exit
    End If
End Sub

コメント

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