ワークシートの比較ツール
Mainの【ワークシート比較ツール.xlsm】と、結果を書き込む【ワークシート比較結果雛形.xlsm】の
2つのブックを作成します。(Microsoft365 64bit環境推奨)
マクロコードの貼り付け
作成されたMainファイルに標準モジュールを追加します。
- 【Alt】+【F11】キーを押下し、VBE画面を表示
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成
- 下記ボックス内をコピーし、標準モジュールに貼り付け
- モジュール名を【B01_Tool】に変更
モジュール名: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 "選択1" r = 4 strTtl = "比較結果雛形ファイル 選択" blFdr = False Case "選択2" r = 5 strTtl = "保存先フォルダ 選択" blFdr = True Case "選択3" r = 9 strTtl = "比較ファイル① 選択" blFdr = False Case "選択4" 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 = "取得1" Then tgtName = .Range("C9").Value tgtPath = .Range("E9").Value ElseIf Application.Caller = "取得2" 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 = "指定1" Then .Cells(9, 7).Value = tgtShtName ElseIf Application.Caller = "指定2" 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
コメント