G-Tool2-Main-B01_WS比較用

Excel VBA
2023.10.07

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

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

マクロコードの貼り付け

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

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


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

　モジュール名：B01_Tool
Option Explicit

'====================================================
'    64bit : Sleep使用のおまじない
'    Sleep 1000　　　　　　　　　　　　'1秒
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
'====================================================
'====================================================
'    【Main】シート ファイル、フォルダーの選択
'====================================================
Public Sub FilePathSelect()

    Dim selectedPath As String
    Dim r As Integer
    Dim c As Integer
    Dim higherDir As String
    Dim myPath As String
    Dim strTtl As String
    
    Dim blFdr As Boolean
    c = 5

    Call SetObject
    
    Select Case Application.Caller
        Case "選択１"
            r = 4
            strTtl = "比較結果雛形ファイル 選択"
            blFdr = False
        Case "選択２"
            r = 5
            strTtl = "保存先フォルダ 選択"
            blFdr = True
        Case "選択３"
            r = 9
            strTtl = "比較ファイル① 選択"
            blFdr = False
        Case "選択４"
            r = 10
            strTtl = "比較ファイル② 選択"
            blFdr = False
    End Select
    
    myPath = ThisWorkbook.Path
    
    With wsMain
        selectedPath = Trim(.Cells(r, c).Value)
        If blFdr Then
        'フォルダ選択が押下された場合
            With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = strTtl
                .AllowMultiSelect = False
                If selectedPath = "" Then
                    higherDir = Left(myPath, InStrRev(myPath, "\") - 1)
                    .InitialFileName = higherDir & "\"
                Else
                    higherDir = Left(selectedPath, InStrRev(selectedPath, "\") - 1)
                    .InitialFileName = higherDir & "\"
                End If

                If .Show = -1 Then
                    wsMain.Cells(r, c).Value = .SelectedItems(1)
                End If
            End With
            
        Else
        'ファイル選択が押下された場合
            With Application.FileDialog(msoFileDialogFilePicker)
                .Title = strTtl
                .AllowMultiSelect = False
                .Filters.Clear
                .Filters.Add "エクセルブック", "*.xls*"
                If selectedPath = "" Then
                    higherDir = Left(myPath, InStrRev(myPath, "\") - 1)
                    .InitialFileName = higherDir & "\"
                Else
                    .InitialFileName = selectedPath
                End If
                If .Show = True Then
                    wsMain.Cells(r, c).Value = .SelectedItems(1)
                End If
            End With
    End If
    End With
    Call ReSetObject

End Sub
'====================================================
'     【Main】シート 【取得】ボタン押下で作動
'      シート名を取得
'====================================================
Sub GetShtName()

    Dim ttlRow As Long
    Dim tgtPath As String
    Dim tgtName As String
    Dim tgtBook As Workbook
    Dim i As Long
    Dim shtCnt As Long
    Dim myAry As Variant
    Dim nmlTmn As Boolean       '正常終アフラグ：normal Termination
    
    Bln_Err = False
    nmlTmn = False

    ErrProsName = "GetShtName"
    On Error GoTo GetShtName_Err
    
    Call SetObject
    With wsMain
        If Application.Caller = "取得１" Then
            tgtName = .Range("C9").Value
            tgtPath = .Range("E9").Value
        ElseIf Application.Caller = "取得２" Then
            tgtName = .Range("C10").Value
            tgtPath = .Range("E10").Value
        End If
        
        If Dir(tgtPath, vbNormal) = "" Or tgtPath = "" Then

            MsgBox "一覧収得したいファイルパスを確認して下さい｡ " & vbCr & _
                   "処理を終了します。"
            GoTo GetShtName_Exit
        End If
            .Range("H12") = tgtName & " ： シート名"
            Call showStatus(tgtName & " ： シート名取得中 ")
            Call StopUpdating
'******************************************************************
        'エラーを無視
        On Error Resume Next
        
        'テーブルクリーニング
        With .ListObjects(1)
            ttlRow = .HeaderRowRange.Row
            .ShowAutoFilter = False
            .DataBodyRange.Delete
            .DataBodyRange.Interior.Color = xlNone    '背景色無色
            .ShowAutoFilter = True
        End With
        
        'エラー制御を戻す
        On Error GoTo 0
'******************************************************************
        
        'リンク更新せず､読み取り専用で開く
        Set tgtBook = Workbooks.Open(Filename:=tgtPath, ReadOnly:=True, UpdateLinks:=0)
        With tgtBook
        
            shtCnt = Worksheets.Count
            ReDim myAry(1 To shtCnt, 1 To 2)
            For i = 1 To shtCnt
                myAry(i, 1) = i
                myAry(i, 2) = .Worksheets(i).Name
            Next i
            .Close savechanges:=False
        End With
        
        With wsMain
            .Cells(ttlRow + 1, 7).Resize(shtCnt, 2) = myAry
        End With
        Set tgtBook = Nothing
        
    End With
    
    nmlTmn = True

GetShtName_Exit:
    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating

    If nmlTmn Then
        MsgBox "ワークシート名を取得しました♪ "
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
GetShtName_Err:
    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
    Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear       'エラー情報クリア
    GoTo GetShtName_Exit
    
End Sub
'====================================================
'     【Main】シート 【指定】ボタン押下で作動
'     セルF11以下の選択したシート名を
'     改行区切りを付けて1セルにまとめる
'====================================================
Sub SelectTgt()

    Dim tgtShtName As String
    Dim i As Long
    Dim MaxRow As Long
    Dim tgtCnt As Long
    Dim tgtRng As Range
    
    Dim nmlTmn As Boolean       '正常終アフラグ：normal Termination
    
    Const sttRow As Long = 13

    Bln_Err = False
    nmlTmn = False
    
    ErrProsName = "SelectTgt"
    On Error GoTo SelectTgt_Err
    
    Call showStatus("指定シート名記入中")
    
    Call StopUpdating
    Call SetObject
    
    With wsMain
        MaxRow = .Cells(Rows.Count, 8).End(xlUp).Row
        Set tgtRng = .Range(.Cells(sttRow, 7), .Cells(MaxRow, 7))
        'ワークシート一覧の数調査
        tgtCnt = WorksheetFunction.CountIf(tgtRng, ChrW("&H2713"))
        If tgtCnt = 0 Then
            MsgBox "対象シート名を指定して下さい" & vbCr & _
                "処理を終了します。", vbExclamation
                GoTo SelectTgt_Exit

        ElseIf tgtCnt > 3 Then
            MsgBox "ワークシートは3つ以下で指定して下さい" & vbCr & _
                "処理を終了します。", vbExclamation
                GoTo SelectTgt_Exit
        End If
        
        For i = sttRow To MaxRow
            'E列にチェックマークが入っているとき
            If .Cells(i, 7).Value = ChrW("&H2713") Then
                If tgtShtName = "" Then
                    tgtShtName = .Cells(i, 8).Value
                Else
                    tgtShtName = tgtShtName & vbLf & .Cells(i, 8).Value
                End If
            End If
        Next i
    
        '指定されたシート名を記入
        If Application.Caller = "指定１" Then
            .Cells(9, 7).Value = tgtShtName
        ElseIf Application.Caller = "指定２" Then
            .Cells(10, 7).Value = tgtShtName
        End If

    End With

    nmlTmn = True
    
SelectTgt_Exit:
    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating
    
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
    
SelectTgt_Err:

    Bln_Err = True
     MsgBox "実行時エラー:" & Err.Nuer & "" & _
    Err.Description & vbCr & _
        "処理を終了します。", vbExclamation, ErrProsName
    Err.Clear       'エラー情報クリア
    GoTo SelectTgt_Err
End Sub

'====================================================
'     Clear
'====================================================
Sub exeClear()

    Dim CmdNo As Long
    Dim nmlTmn As Boolean       '正常終アフラグ：normal Termination
    
    Bln_Err = False
    nmlTmn = False
    
    ErrProsName = "exeClear"
    On Error GoTo exeClear_Err
    
    Call StopUpdating
    Call SetObject
    
    Select Case Application.Caller
        Case "青Clear"
            CmdNo = 1
        Case "緑Clear"
            CmdNo = 2
    End Select
    
    With wsMain

        If CmdNo = 1 Then
            .Range("E4:E5").Value = ""
            .Range("E6").ClearContents
            .Range("E9:E10").Value = ""
        ElseIf CmdNo = 2 Then
            .Range("G9:G10").Value = ""
            .Range("C12").Value = ""
    
    '**************************************************
            'エラーを無視
            On Error Resume Next
    
            'テーブルクリーニング
            With .ListObjects(1)
                .ShowAutoFilter = False
                .DataBodyRange.Delete
                .DataBodyRange.Interior.Color = xlNone    '背景色無色
                .ShowAutoFilter = True
            End With
            .Range("ワークシート[[#All],[Chk]]").HorizontalAlignment = xlCenter
            'エラー制御を戻す
            On Error GoTo 0
    '**************************************************
        End If
    End With
    
    nmlTmn = True
    
exeClear_Exit:
    'エラーを無視
    On Error Resume Next
    Call ReSetObject
    Call Updating
    
    If nmlTmn Then
        MsgBox "完了♪"
    End If
    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub
exeClear_Err:

    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Nuer & "" & _
         Err.Description & vbCr & _
         "処理を終了します。", vbExclamation, ErrProsName
        Err.Clear       'エラー情報クリア
        GoTo exeClear_Exit

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

'+++***********************************************+++
'     シート検出: シート番号を返す
'     Call IsShtNo(nameHead, OtrwbName)
'+++***********************************************+++
Public Function IsShtNo(nameHead As String, wbName As String) As Long
    
    Dim Otrwb As Workbook
    Dim i As Long
    Dim myLen As Long
    
    IsShtNo = 0
    Set Otrwb = Workbooks(wbName)
    With Otrwb
        myLen = Len(nameHead)
        For i = 1 To .Worksheets.Count
            If Left(.Worksheets(i).Name, myLen) = nameHead Then
                IsShtNo = i
                Exit For
            End If
        Next i
    End With
End Function

'+++***********************************************+++
'     全ての外部リンクを一括削除
'+++***********************************************+++
Sub BreakLink()

    Dim wb As Workbook
    Dim Link As Variant
    
    Set wb = Application.ActiveWorkbook
    
    If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
        For Each Link In wb.LinkSources(xlExcelLinks)
            wb.BreakLink Link, xlLinkTypeExcelLinks
        Next Link
    End If
End Sub

'+++****************************************************+++
'     指定シートの余分な余白やマクロボタンを削除 等を行う
'     Call cutShtExtra(shtName, dstBookName)
'+++****************************************************+++
Public Function cutShtExtra(shtName As String, dstBookName As String)

    Dim sht As Worksheet
    Dim dstBook As Workbook
    Dim tgtSht As Worksheet
    Dim j As Long               '各列
    Dim xRow As Long            '1列の最終行
    Dim MaxRow As Long          '最終行
    Dim MaxCol As Long          '最終列
    Dim shp As Shape

    Set dstBook = Workbooks(dstBookName)
    Set tgtSht = dstBook.Worksheets(shtName)
    With tgtSht
        'シート内のマクロ図形を消去
        For Each shp In .Shapes
            'エラーを無視
            On Error Resume Next
            '登録されたマクロは削除
            shp.OnAction = ""
            'マクロボタンは削除
            If shp.Type = msoFormControl Then
                shp.Delete
            End If
            'エラー制御を戻す
            On Error GoTo 0
        Next shp
        
        '使用済み範囲の最終行､最終列
        With .UsedRange
            MaxCol = Columns(.Columns.Count).Column
        End With

        'UsedRangeのMaxRowが実際よりも大きくなっている場合
        'UsedRangeのMaxColの範囲でMaxRowを取る｡
        MaxRow = 0
        For j = 1 To MaxCol
            xRow = .Cells(Rows.Count, j).End(xlUp).Row
            If MaxRow < xRow Then
                MaxRow = xRow
            End If
        Next j
        MaxCol = MaxCol + 1
        MaxRow = MaxRow + 1
        '余分な右部分を削除
        .Range(.Columns(MaxCol), .Columns(MaxCol).End(xlToRight)).Delete Shift:=xlToLeft
        '余分な下部分を削除
        .Range(.Rows(MaxRow), .Rows(MaxRow).End(xlDown)).Delete Shift:=xlUp
        
        '■ スクロールして先頭に移動する
        Application.GoTo Reference:=.Range("A1"), Scroll:=True
    
    End With

    'エラーを無視
    On Error Resume Next
    Set dstBook = Nothing
    Set tgtSht = Nothing
    'エラー制御を戻す
    On Error GoTo 0
End Function

コメント

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