◎一例として下図のようなダイアログを作成



Option Explicit
Option Base 1
Option Private Module


Option Explicit
Option Private Module

'汎用的に使える関数を記載する

Function ChkSheet(strSheet As String) As Boolean
' シート存在チェック関数
' 引数　 strSheet ：存在を確認するシート名
' 戻り値 Boolean  ：True ：存在した時
'                 ：False：存在しない時

  Dim ws As Worksheet
    
  ChkSheet = False
  For Each ws In Worksheets
    If ws.Name = strSheet Then
      ChkSheet = True
      Exit For
    End If
  Next
End Function


Function JudgeSheetExist(ByVal TargetSheetName As String) As Boolean
'ターゲットシートの存在の有無を判定し、なかったらターゲット
'シートを作成する
'引数 TargetSheetName:シート名の文字列
'戻値 成功：True ,失敗：False
    Dim errFlag As Boolean
    Dim wksSheet As Worksheet
    Dim strTarget As String
    
    strTarget = TargetSheetName
    errFlag = False
    For Each wksSheet In Worksheets
        If wksSheet.Name = strTarget Then
            errFlag = True
            Exit For
        End If
    Next
    If errFlag <> True Then  'なかったら
                            'ターゲットシートを作成
        Set wksSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))  '一番最後に追加
        wksSheet.Name = strTarget
        errFlag = True
    End If
    'オブジェクト解放
    Set wksSheet = Nothing
    
    JudgeSheetExist = errFlag
End Function

Function SpecialDataInsert(ByVal TargetSheetName As String, ByVal InsertRow As Long, _
                           ByVal DataMatrix As Variant) As Boolean
'指定されたシートに指定レコード(2次元配列x,y)を最終行に追加する
'
'引数1：TargetSheetName     シート名
'引数1：InsertRow           挿入開始行
'引数1：DataMatrix          レコードを定義した配列
'戻値：　成功:TRUE　失敗:FALSE
    Dim x, y As Long
    Dim xMax As Long
    Dim yMax As Long
    Dim wksTargetSheet As Worksheet
    
    On Error GoTo Hdl_SDI_ERROR         'エラー処理
    Set wksTargetSheet = ThisWorkbook.Worksheets(TargetSheetName)
      
    wksTargetSheet.Cells(1, 1).Select
    xMax = UBound(DataMatrix, 1)
    yMax = UBound(DataMatrix, 2)
    For y = 1 To yMax Step 1
        For x = 1 To xMax Step 1
            wksTargetSheet.Cells(y + InsertRow, x).Value = DataMatrix(x, y)
        Next
    Next
    SpecialDataInsert = True
    Exit Function
Hdl_SDI_ERROR:
    'オブジェクト解放
    Set wksTargetSheet = Nothing
    
    SpecialDataInsert = False
End Function

Function DeleteSheet(ByVal TargetSheetName As String, ByVal strActBookName As String) As Boolean
'指定したブックの指定シートの削除をする関数
'
    Dim objActiveBook As Object
    Dim objWorkSheet  As Object
    
    On Error GoTo Hdl_Del_ERROR
    Application.DisplayAlerts = False
    
    Set objActiveBook = Workbooks(strActBookName)
    Set objWorkSheet = objActiveBook.Sheets(TargetSheetName)
    objWorkSheet.Delete
    Application.DisplayAlerts = True
    DeleteSheet = True
    Exit Function
Hdl_Del_ERROR:
    Application.DisplayAlerts = True
    Set objWorkSheet = Nothing
    Set objActiveBook = Nothing
    DeleteSheet = False
End Function

Function DeleteSheetFromPartialSheetName(ByVal MatchingWord As String, _
                                         ByVal strActBookName As String) As Boolean
'指定ブックの部分一致文字列で指定したシートの削除をする関数
'
    Dim objActiveBook As Object
    Dim objWorkSheet  As Object
    Dim i As Integer                'カウンタ
    Dim ShtName As String           'シート名
        
    'エラー処理 & 警告無効
    On Error GoTo Hdl_Del_ERROR
    Application.DisplayAlerts = False
    
    'ブック名のセット
    Set objActiveBook = Workbooks(strActBookName)
    
    '存在するか判定し、あったら削除
    For Each objWorkSheet In objActiveBook.Worksheets
        ShtName = objWorkSheet.Name
        If ShtName Like "*" & MatchingWord & "*" Then
            objWorkSheet.Delete
            DeleteSheetFromPartialSheetName = True
        End If
    Next objWorkSheet
    
    '警告を有効に
    Application.DisplayAlerts = True

    Exit Function
Hdl_Del_ERROR:
    Application.DisplayAlerts = True
    Set objWorkSheet = Nothing
    Set objActiveBook = Nothing
    DeleteSheetFromPartialSheetName = False
End Function

Function ConcatenateRangeText(ByRef objCells As Range) As String
'指定したセル範囲の文字列を連結するユーザー定義関数
'上記のコードをVBE（Visual Basic Editor）を起動して標準モジュールに
'貼り付ければ、普通のワークシート関数と同様に使えます。
'
'A1セルからA3セルにデータが入力されているときに、A4セルに
'「=ConcatenateRangeText(A1:A3)」と入力してやれば、
'A4セルにA1セルからA3セルのデータが連結される
'http://www.relief.jp/itnote/archives/001342.php 丸パクリ
'※スペースは除去するように変更

    Dim objCell As Range
    Dim strRet As String
    strRet = ""
    For Each objCell In objCells
        strRet = strRet & objCell.Text
    Next
    strRet = Replace(strRet, " ", "")
    ConcatenateRangeText = strRet

End Function

Public Sub ToggleSheetProtect()
'選択されているシートの保護を切り替える
'保護・保護解除がトグルで動作
    Dim sh As Object
   
    '選択したシートを列挙する
    For Each sh In ActiveWindow.SelectedSheets
        sh.Select   'そのシートを選択する
        If sh.ProtectContents = True Then   'シートが保護の時
            sh.Unprotect
        Else                                'シートが保護されてない時
            sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        End If
    Next
End Sub

Function DeleteRecords(ByVal TargetBookPath As String, ByVal TargetCode As String, _
                        Optional ByVal TargetColumn As Long = 1) As Long
'指定ブックの指定列のセルに指定文字列があるレコードを削除する
'引数1：開くブック名(フルパス)
'引数2：指定する文字列(省略時1)
'引数3：削除対象のある列
'戻値：削除したレコード数(-1はエラー)
    
    Dim i As Long
    Dim strFlg As String
    Dim lngRowNum As Long
    Dim lngRowMax As Long
    Dim lngCount As Long
    Dim wksSheet As Worksheet
    Dim strBookName As String
    
    strBookName = Dir(TargetBookPath)
    
    On Error GoTo Hdl_FileERROR
    Workbooks.Open FileName:=(TargetBookPath)
    Set wksSheet = Workbooks(strBookName).Worksheets(1)
     
    On Error GoTo Hdl_DelERROR
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    wksSheet.Select
    lngRowMax = wksSheet.UsedRange.Rows.Count
    
    '行の削除を実施
    lngRowNum = 1
    lngCount = 0
    Do
        strFlg = CStr(wksSheet.Cells(lngRowNum, TargetColumn).Value)
        If strFlg = CStr(TargetCode) Then   '該当したら削除
            wksSheet.Rows(lngRowNum).EntireRow.Delete
            lngRowMax = lngRowMax - 1
            lngCount = lngCount + 1         '削除した行をカウント
        Else
            lngRowNum = lngRowNum + 1       '該当しなければ次の行へ
        End If
    Loop Until lngRowNum = lngRowMax + 2
    
    '閉じて保存して後始末
    Application.DisplayAlerts = False
    Workbooks(strBookName).Save
    Workbooks(strBookName).Close
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    DeleteRecords = lngCount
    Exit Function
        
Hdl_DelERROR:
    Set wksSheet = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox lngRowNum & "行目の削除時にエラーが発生しました", vbCritical + vbOKOnly
    DeleteRecords = -1
    Exit Function
Hdl_FileERROR:
    MsgBox "ファイルを開けませんでした", vbCritical + vbOKOnly
    DeleteRecords = 0
End Function

Function DateCheck(ByVal mystr As String) As Boolean
'YYYYMMDD形式の文字列を判定する関数
'
    DateCheck = False
    '半角チェック
    If mystr <> StrConv(mystr, vbNarrow) Then Exit Function
    '文字長チェック
    If Len(mystr) <> 8 Then Exit Function
    '日付チェック
    If IsDate(Left(mystr, 4) & "/" & Mid(mystr, 5, 2) & "/" & Right(mystr, 2)) Then
        DateCheck = True
    End If
End Function