G-Tool2-Form-B00_WS比較用

Excel VBA

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

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

マクロコードの貼り付け

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

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

'+++*****************************************************+++
'   ワークシート比較ツール【比較結果】シートを作成
'+++*****************************************************+++
Public Sub MakeResultSht()
    Dim i As Long
    Dim j As Long
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列
    Dim IngColor As Long
    Dim rHeight() As Variant
    Dim cWidth() As Variant
    Dim rowAry() As Variant
    Dim colAry() As Variant
    Dim strAry() As Variant
    
    Dim ColWidth As Double
    Dim bstrWidth As Double
    Dim mgnWidth As Double
    Dim aWdt As Double             'ColumnWidth = 10  :Width
    Dim bWdt As Double             'ColumnWidth = 20  :Width
    Dim cWdt As Double             'ColumnWidth = 1   :Width
    Dim oneDW As Double            'ColumnWidth = 1   :Width
    Dim pOneDw As Double           'ColumnWidth = 0.1 :Width
    Dim myInteger As Double
    Dim myDecimal As Double
    Dim myCW As Double
    
    Dim wbName As String
    Dim rstSht As Worksheet
    Dim IsBlank As Boolean
    
    Const shtName As String = "比較結果"

    Const TTLSTRCOLOR As Long = 11580416      'タイトル文字色
    Const BGCOLOR As Long = 10192433          '青緑
    Const LBCOLOR As Long = 16247773          '薄めの青
    Const LGCOLOR As Long = 15921906          'ライトグレー
    Const LINECOLOR As Long = 10921638        'ライトグレー2
    Const MYCOLOR1 As Long = 6299648          '紺
    Const MYCOLOR2 As Long = 14772545         '青
    Const MYCOLOR3 As Long = 13749760         'エメラルド
    
    rHeight = Array(0, 7.5, 25.5, 1.5, 5, 2, 13.5, 2.5, 27.5, 7, 27.5, 9.5, _
                19, 19, 19, 7.5, 14, 4, 19, 13.5)
'    cWidth = Array(0, 0.63, 0.63, 5, 6.4, 15.67, 15.67, 0.63, 0.63, 5, 6.4, _
'                15.67, 15.67, 0.63, 0.63, 5, 6.4, 16, 16, 0.63, 0.63)
    cWidth = Array(0, 7.5, 7.5, 42, 52.5, 122, 122, 7.5, 7.5, 42, 52.5, _
                 122, 122, 7.5, 7.5, 42, 52.5, 124.5, 124.5, 7.5, 7.5)
    rowAry = Array(0, 2, 2, 2, 8, 10, 12, 12, 12, 12, 12, 12, _
                13, 13, 13, 14, 14, 14, 16, 16, 16, 18, 18, 18, 18, 18, 18, _
                18, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19)
    colAry = Array(0, 4, 12, 13, 3, 3, 3, 5, 9, 11, 15, 17, 5, _
                11, 17, 3, 9, 15, 3, 9, 15, 3, 4, 5, 6, 7, 9, 10, 11, 12, _
                13, 15, 16, 17, 18, 19, 3, 9, 15)
    strAry = Array(0, "シート比較結果", "Ver.1.0", _
                "比較実行日時", "比較ファイル①", "比較ファイル②", "a", _
                "比較セル数", "b", "比較セル数", "c", "比較セル数", _
                "不一致件数", "不一致件数", "不一致件数", _
                "比較元 シート名", "比較元 シート名", "比較元 シート名", _
                "不一致セル、値(1,000件まで）", _
                "不一致セル、値(1,000件まで）", _
                "不一致セル、値(1,000件まで）", "NO", "セル位置", _
                "a ①（値）", "a ②（値）", " ", "NO", "セル位置", _
                "b ①（値）", "b ②（値）", " ", "NO", "セル位置", _
                "c ①（値）", "c ②（値）", " ", "1", "1", "1")

    Call StopUpdating
    wbName = ActiveWorkbook.Name
'******************************************************************************
    '日本語　フォントテーマをMeiryo UIで設定
    With ActiveWorkbook.Theme.ThemeFontScheme
        .MajorFont.Item(3).Name = "Meiryo UI"      '見出しのフォント
        .MinorFont.Item(3).Name = "Meiryo UI"      '本文のフォント
    End With
'******************************************************************************
    IsBlank = False
    If IsShtOwb(shtName, wbName) = False Then
        With Worksheets(1)
            With .UsedRange
                MaxRow = .Rows(.Rows.Count).Row
                MaxCol = .Columns(.Columns.Count).Column
            End With
        End With
        If MaxRow = 1 And MaxCol = 1 Then
            IsBlank = True
        End If
        If IsBlank Then
            Worksheets(1).Name = shtName
        Else
            ActiveWorkbook.Worksheets.Add Before:=Worksheets(1)
            ActiveSheet.Name = shtName
        End If
    Else
        With ActiveWorkbook.Worksheets(shtName)
            .Select
            .Cells.Clear
        End With
        Call delShapes
    End If
    Set rstSht = ActiveWorkbook.Worksheets(shtName)
    With rstSht
        .Select
        .Cells.VerticalAlignment = xlCenter
        ActiveWindow.FreezePanes = False
        .Cells(19, 1).Select
        ActiveWindow.FreezePanes = True
        ActiveWindow.Zoom = 85
        With .Cells.Font
            .ThemeFont = xlThemeFontNone
            .Name = "Meiryo UI"
            .Size = 10
        End With
        
'*********************************************
        'フォントテーマが " Meiryou UI"でなくても
　　　　'列幅を正しく反映させるための処理

        .Columns(1).ColumnWidth = 10
        .Columns(2).ColumnWidth = 20
        .Columns(3).ColumnWidth = 1

        aWdt = .Columns(1).Width
        bWdt = .Columns(2).Width
        cWdt = .Columns(3).Width
        
        mgnWidth = 2 * aWdt - bWdt
        bstrWidth = (bWdt - aWdt) / 10    'Width/1文字
        oneDW = cWdt
        pOneDw = cWdt / 10

        'Width が ColumnWidth =1　以下の場合は、
        '計算方法を変更
        '多少、アバウトになるが、1CWあたりのWidthを比例させて使用
        
'*********************************************

        .Cells.RowHeight = 15.5
        .Cells.ColumnWidth = 8.5
        For i = 1 To UBound(rHeight)
            .Rows(i).RowHeight = rHeight(i)
        Next i
        For i = 1 To UBound(cWidth)
            If cWidth(i) > oneDW Then
                myCW = (cWidth(i) - mgnWidth) / bstrWidth
            Else
                myCW = cWidth(i) / oneDW
            End If
            .Columns(i).ColumnWidth = myCW
        Next i
        For i = 1 To UBound(strAry)
            .Cells(rowAry(i), colAry(i)).Value = strAry(i)
        Next i
        .Range("B4:T4").Interior.Color = TTLSTRCOLOR
        With .Range("D2").Cells.Font
            .Size = 16
            .Bold = True
            .Color = TTLSTRCOLOR
        End With
        With .Range("L2").Cells
            With .Font
                .Size = 12
                .Bold = True
                .Color = TTLSTRCOLOR
            End With
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlBottom
            'インテンドを1入れる
            .InsertIndent 1
        End With
        With .Range("M2:P2")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .Interior.Color = LBCOLOR
        End With
        .Range("B6:T15").Interior.Color = LBCOLOR
        With .Range("C8:D8")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .Interior.Color = BGCOLOR
            With .Font
                .Size = 11
                .Bold = True
                .Color = vbWhite
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("C10:D10")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .Interior.Color = BGCOLOR
            With .Font
                .Size = 11
                .Bold = True
                .Color = vbWhite
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("E8:K8")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("E10:K10")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("L8,L10")
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("C12:D13")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 2
            .Interior.Color = MYCOLOR1
            With .Font
                .Size = 20
                .Bold = True
                .Color = vbWhite
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        
        With .Range("I12:J13")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 2
            .Interior.Color = MYCOLOR2
            With .Font
                .Size = 20
                .Bold = True
                .Color = vbWhite
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        
        With .Range("O12:P13")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 2
            .Interior.Color = MYCOLOR3
            With .Font
                .Size = 20
                .Bold = True
                .Color = vbWhite
            End With
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        
        With .Range("E12,E13,K12,K13,Q12,Q13")
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = LGCOLOR
            .Font.Size = 9
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("C14:D14")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = LGCOLOR
            .Font.Size = 9
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("I14:J14")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = LGCOLOR
            .Font.Size = 9
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("O14:P14")
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = LGCOLOR
            .Font.Size = 9
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        
        With .Range("F12,F13,L12,L13,R12,R13")
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlRight
            .InsertIndent 1
            .Interior.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        
        With .Range("E14,F14,K14,L14,Q14,R14")
            .HorizontalAlignment = xlCenter
            .HorizontalAlignment = xlLeft
            .InsertIndent 1
            .Interior.Color = vbWhite
            With .Borders
                .LineStyle = xlContinuous
                .Color = LINECOLOR
                .Weight = xlThin
            End With
        End With
        With .Range("C16:R16")
            With .Font
                .Size = 9
                .Bold = True
                .Color = BGCOLOR
            End With
        End With
        With .Range("C18:G18")
            .HorizontalAlignment = xlLeft
            .Interior.Color = MYCOLOR1
            With .Font
                .Size = 9
                .Bold = True
                .Color = vbWhite
            End With
        End With
        .ListObjects.Add(xlSrcRange, Range("$C$18:$G$19"), _
             , xlYes).Name = "TableA"
        .ListObjects("TableA").TableStyle = "TableStyleLight11"
        With .Range("I18:M18")
            .HorizontalAlignment = xlLeft
            .Interior.Color = MYCOLOR2
            With .Font
                .Size = 9
                .Bold = True
                .Color = vbWhite
            End With
        End With
        .ListObjects.Add(xlSrcRange, Range("$I$18:$M$19"), _
             , xlYes).Name = "TableB"
        .ListObjects("TableB").TableStyle = "TableStyleLight11"
        With .Range("O18:S18")
            .HorizontalAlignment = xlLeft
            .Interior.Color = MYCOLOR3
            With .Font
                .Size = 9
                .Bold = True
                .Color = vbWhite
            End With
        End With
        .ListObjects.Add(xlSrcRange, Range("$O$18:$S$19"), _
             , xlYes).Name = "TableC"
        .ListObjects("TableC").TableStyle = "TableStyleLight11"
        '念のため、列幅を再設定
        For i = 1 To UBound(cWidth)
            If cWidth(i) > oneDW Then
                myCW = (cWidth(i) - mgnWidth) / bstrWidth
            Else
                myCW = cWidth(i) / oneDW
            End If
            .Columns(i).ColumnWidth = myCW
        Next i

        Call MakeButtons2
        .Cells(1, 1).Select

    End With
    Call Updating
End Sub

'+++*****************************************************+++
'   ワークシート比較ツール【比較結果】シート
'   ボタンを作成
'+++*****************************************************+++
Public Sub MakeButtons2()
    Dim nameArray As Variant
    Dim textArray As Variant
    Dim macroArray As Variant
    Dim pstnArray As Variant
    Dim myPosi As Variant
    Dim myBtn As Object
    Dim i As Long
    Dim myShp As Shape
    
    nameArray = Array("", "保存２", "開く 2", "保存１", "開く 1", _
        "自動計算")
    textArray = Array("", "変更を保存して閉じる", _
        "読み取り 手動計算で開く", "変更を保存して閉じる", _
        "読み取り 手動計算で開く", "自 動 計 算")
    macroArray = Array("", "exeSaveClose", "openFile", _
        "exeSaveClose", "openFile", "AutoCalc")

    pstnArray = Array("0,0,0,0", "831.5,92.5,103,27,27", _
        "719.5,92.5,103,27,27", "831.5,58,103,27,27", _
        "719.5,58,103,27,27", "962.283,4,103.5,27.5,27.5")
                    
    With ActiveSheet
        For i = 1 To UBound(nameArray)
            myPosi = Split(pstnArray(i), ",")
            Set myBtn = .Buttons.Add(myPosi(0), _
                                 myPosi(1), _
                                 myPosi(2), _
                                 myPosi(3))
            With myBtn
                .Name = nameArray(i)
                .Font.Name = "Meiryo UI"    　　'文字のサイズ
                With .Characters                'テキスト
                    .Text = textArray(i)        '文字列
                    .Font.Size = 9              '文字のサイズ
                End With
                .OnAction = macroArray(i)
            End With
        Next i
        
        Set myShp = .Shapes.AddTextbox(msoTextOrientationHorizontal, _
                941.6, 41.5, 124, 86.43)
        With myShp

            With .TextFrame2.TextRange.Font
                .Size = 10               　　　　　　 '文字のサイズ
                .NameComplexScript = "Meiryo UI"　　  '文字のフォント
                .NameFarEast = "Meiryo UI"
                .Name = "Meiryo UI"
            End With
            .TextFrame2.TextRange.Characters.Text = _
            "コピーされたデータシートの" & vbLf & _
            "マクロ付きボタンや､値の入っていないセルは､処理とファイルを軽くするために消去しています｡ "
            
            With .TextFrame
                ' テキストを図形からはみ出して表示する
                .HorizontalOverflow = Excel.XlOartHorizontalOverflow.xlOartHorizontalOverflowOverflow
                .VerticalOverflow = Excel.XlOartVerticalOverflow.xlOartVerticalOverflowOverflow
            End With
            
            With .Fill
                .Visible = msoTrue
                .ForeColor.RGB = 16247773
                .Transparency = 0
                .Solid
            End With
        
        End With

    End With
End Sub

コメント

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