InputBoxで設定した範囲だけ選択出来るようにする（シートにマクロ自動設定） Excel2000 VBA

InputBoxで設定した範囲だけ選択出来るようにする（シートにマクロ自動設定）

最初にワークシートイベントを有効、無効にするマクロ作成する。（無効にしてシートの数式編集など、有効にして入力作業）

Sub シートイベント有効無効()
’実行する度に有効→無効→有効→
If Application.EnableEvents = False Then Application.EnableEvents = True Else Application.EnableEvents = False
End Sub

Sub 設定範囲だけ選択できるようにする()
'「シートイベントで名前のある範囲だけ選択できる（入力）ようにする。」、
'コードをシートモジュールにに追記する
'On Error GoTo Er
  Dim W_Book  As Workbook
  Dim book_name, sheet_name, myProcName As String
  Dim i, end_line As Long
'アクティブブック名シート名取得（モジュールを追加する）
    book_name = ActiveWorkbook.Name
    sheet_name = ActiveSheet.Name
'book set
    Set W_Book = Workbooks(book_name)
   
'書き込むプロシージャ名と同じ名があるかチェック
  
    myProcName = "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
   
    With W_Book.VBProject.VBComponents.Item(sheet_name).CodeModule
        'end_line = .CountOfLines
        For i = 1 To .CountOfLines
        'Debug.Print .Lines(i, 1)
            If myProcName = .Lines(i, 1) Then GoTo owari
            'Debug.Print .Lines(i, 1) '1行ずつコード
        Next i
    End With
   
'挿入書き込み
  With W_Book.VBProject.VBComponents.Item(sheet_name).CodeModule
          .insertlines 2, "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
          .insertlines 3, "On Error Resume Next"
          .insertlines 5, "Dim scope As Range"
          .insertlines 6, "Dim today_row As Long"
          .insertlines 7, "Set scope = Range(" & Chr(34) & "入力" & Chr(34) & ")"
          .insertlines 8, "With Application"
          .insertlines 9, "If .Intersect(Target, scope) Is Nothing Then"
          .insertlines 10, ".EnableEvents = False"
          .insertlines 11, ".PreviousSelections(1).Select"
          .insertlines 12, ".EnableEvents = True"
          .insertlines 13, "Else"
          .insertlines 14, ".Goto ActiveCell"
          .insertlines 15, "End If"
          .insertlines 16, "End With"
          .insertlines 17, "If Target.HasFormula = True Then Target.Offset(0, 1).Select"
          .insertlines 18, "Set scope = Nothing"
          .insertlines 19, "End Sub"
          .insertlines 20, ""
 
  End With
  Set W_Book = Nothing

'INputBoxで選択できる範囲を設定
hani_set:
Dim hani As Range
Dim inC As String
On Error GoTo Er
'ワークシートイベントを無効にする
    Application.EnableEvents = False
'範囲取得
    inC = "名前を付ける範囲を指定（名前「入力」）" & vbLf + vbLf & "Ctrlキーを押しながら複数の範囲指定も可" _
    & vbLf + vbLf & "注意　現在設定されている名前は無効になります。"
   
    Set hani = Application.InputBox(inC, Type:=8)
  
'選択範囲に名前をつける。名前は「入力」
    hani.Name = "入力"
    'hani.Names.Add Name:="入力", RefersTo:=sheet_name, Visible:=False
    hani.Interior.ColorIndex = 6 '名前をつけた範囲を分かりやすくする為色を設定
  
'ワークシートイベントを有効にする
    Application.EnableEvents = True

Set hani = Nothing
  MsgBox "設定範囲だけ選択可　完了"
  Exit Sub
owari:
Dim MB As Variant
    Set W_Book = Nothing
  MB = MsgBox("既にプロシージャが存在します。" & vbCrLf + vbCrLf & "範囲を設定しますか？", vbYesNo)
  Select Case MB
  Case vbYes
    GoTo hani_set
    Case vbNo
    Set hani = Nothing
End Select
Er:
'InputBoxでキャンセルが押されてエラーになったら
End Sub

ダウンロードは🎥こちら

ダウンロードは🎥こちら

 

タグ：Excel2000 VBA