Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7752 / 13644 ツリー ←次へ | 前へ→

【37062】リストを利用して、シートの移動 16茶 06/4/20(木) 16:38 質問[未読]
【37063】Re:リストを利用して、シートの移動 Statis 06/4/20(木) 16:43 回答[未読]
【37066】Re:リストを利用して、シートの移動 16茶 06/4/20(木) 16:50 質問[未読]
【37067】Re:リストを利用して、シートの移動 Statis 06/4/20(木) 16:53 発言[未読]
【37092】Re:リストを利用して、シートの移動 16茶 06/4/21(金) 8:17 発言[未読]
【37068】Re:リストを利用して、シートの移動 Kein 06/4/20(木) 17:37 回答[未読]
【37069】Re:リストを利用して、シートの移動 Kein 06/4/20(木) 17:42 発言[未読]
【37091】Re:リストを利用して、シートの移動 16茶 06/4/21(金) 8:09 お礼[未読]

【37062】リストを利用して、シートの移動
質問  16茶 E-MAIL  - 06/4/20(木) 16:38 -

引用なし
パスワード
   初めまして、いつも参考にさせていただいています。

今日は、行き詰まってしまったので質問させていただきたいと思います。

提出書類と言うワークシートを作成しています。
その中のシートに入力規則でリストセルを設けています。
そのセル内に別のワークシート名をリスト化して、選択したときに
その名前の付いているシートへジャンプしたいのですが、どうもうまくいきません。
ハイパーリンクという方法もあるのですが、そのリストセルを参照して、印刷時の表紙に名前を付けたりしています。

印刷時は、

表紙(リストセルを参照して名前を付ける)

作成する書類

このように印刷されます。
ですので、リストからジャンプする方法を取りたいのですが、何か良いお知恵をお貸し願えませんでしょうか?

OSは、winXPで、エクセルは、2003を使用しています。

何とぞよろしくお願いします。

【37063】Re:リストを利用して、シートの移動
回答  Statis  - 06/4/20(木) 16:43 -

引用なし
パスワード
   こんにちは

下記のコードを該当にシートモジュールに記載して下さい。
セルA1(入力規則が事前に設定してあること)のみ対応します


Private Sub Worksheet_Change(ByVal Target As Range)
With Target
   If .Address(0, 0) <> "A1" Then Exit Sub
   If IsEmpty(.Value) Then Exit Sub
   Worksheets(.Value).Activate
End With
End Sub

【37066】Re:リストを利用して、シートの移動
質問  16茶 E-MAIL  - 06/4/20(木) 16:50 -

引用なし
パスワード
   ▼Statis さん:
回答ありがとうございます。

何度かやってみたのですが、いまいちよく分かりません。
お手数をかけて大変申し訳ありませんが、詳しくお教え願えませんでしょうか?

勉強不足で申し訳ありません。

【37067】Re:リストを利用して、シートの移動
発言  Statis  - 06/4/20(木) 16:53 -

引用なし
パスワード
   こんにちは

>何度かやってみたのですが、いまいちよく分かりません。
何をやって何がわからないのでしょうか?

1:入力規則はすでに設定していますか?
2:セルの位置はどこですか?
3:コードの記載場所はわかりますか?

【37068】Re:リストを利用して、シートの移動
回答  Kein  - 06/4/20(木) 17:37 -

引用なし
パスワード
   提出書類シートのシートモジュールに入れて下さい。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

【37069】Re:リストを利用して、シートの移動
発言  Kein  - 06/4/20(木) 17:42 -

引用なし
パスワード
   A1 に入力規則を設定するには、マクロをシートモジュールに入れた後、
いったん提出書類シート以外のシートを開いてから、提出書類シートに戻ります。
そうしないとシートアクティブイベントが動作しませんから。
なお、私のコードは解説しません。分からない語句はカーソルを当てて、F1キー
を押してヘルプを出し、自分で調べること。

【37091】Re:リストを利用して、シートの移動
お礼  16茶 E-MAIL  - 06/4/21(金) 8:09 -

引用なし
パスワード
   ▼Kein さん:

大変どうもありがとうございました。
参考にして勉強させていただきます

【37092】Re:リストを利用して、シートの移動
発言  16茶 E-MAIL  - 06/4/21(金) 8:17 -

引用なし
パスワード
   Statis さん

>1:入力規則はすでに設定していますか?

はい、b5セルに入力規則−リストで設定してあります。
各シートにはシート名を変更して作成する名称が付けてあります。
入力規則用のリストは、f列に表で作成してあります。

>3:コードの記載場所はわかりますか?

statisさんに教えていただいたマクロコードを
標準モジュールのmodule1にコピーさせていただき
オートシェイプにマクロ設定しました。
デバック時にエラーが出てきたのですが、訳が分からず
先日のような再質問になりました。
申し訳ありません。<(_ _)>

7752 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free