| |
提出書類シートのシートモジュールに入れて下さい。A1セルに入力規則を設定する、
という前提で全ての処理が出来るコードにしてみました。
Private Sub Worksheet_Activate()
Dim MyR As Range
Dim WS As Worksheet
Dim SAry() As String
Dim i As Integer
On Error Resume Next
Set MyR = Intersect(Range("A1"), _
Range("A1").SpecialCells(-4174))
On Error GoTo 0
If MyR Is Nothing Then
For Each WS In Worksheets
If WS.Index <> ActiveSheet.Index Then
i = i + 1
ReDim Preserve SAry(i): SAry(i) = WS.Name
End If
Next
Range("A1").Validation.Add xlValidateList, _
, , Join(SAry, ",")
Err.Clear: Erase SAry
Else
Set MyR = Nothing
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WS As Worksheet
Dim WsN As String, SAry() As String
Dim Ans As Integer, i As Integer
With Target
If .Address <> "$A$1" Then Exit Sub
If .Count > 1 Then Exit Sub
If IsEmpty(.Value) Then Exit Sub
WsN = .Value
End With
On Error Resume Next
Worksheets(WsN).Activate
If Err.Number <> 0 Then
Err.Clear
Ans = MsgBox("選択した名前のシートがありません" & _
vbLf & "リストを更新しますか", 36)
If Ans = 6 Then
For Each WS In Worksheets
If WS.Index <> ActiveSheet.Index Then
i = i + 1
ReDim Preserve SAry(i): SAry(i) = WS.Name
End If
Next
Target.Validation.Modify xlValidateList, _
, , Join(SAry, ",")
If Err.Number <> 0 Then
Target.Validation.Add xlValidateList, _
, , Join(SAry, ",")
End If
Erase SAry
End If
End If
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 06/4/20(木) 16:38 -
