一つのセルに【データの入力規制】でリストを入れています。その値をそのセル上で選ぶときは、ALT+↓で選びますよね。このことと同じことをマクロで、できますか?つまり、マクロを下矢印ボタンや上矢印ボタンに登録し、ボタンを押すたびにそのリスト内容をセルに表示し確認できるようにしたいのです。どなたか分かる方、お願いします。VBAの記述付きで。
'あまり綺麗でないのですが、いかがでしょうか?
'A1 セルに入力規則のリストがあると仮定します。(A1を適宜修正してください)
'▲(上)ボタンを配置して、下記クリックイベントを割り当てます。
'▼(下)ボタンを配置して、下記クリックイベントを割り当てます。
'▲ボタンのクリックイベント
Private Sub btnDown_Click()
Dim GetV As String
Dim MyList As Variant
Dim pos As Integer
Dim s As String
Dim wk As String
Dim rg As Range
GetV = Range("A1").Value
s = Range("A1").Validation.Formula1
If Left(s, 1) = "=" Then
wk = ""
For Each rg In Range(Mid(s, 2))
wk = wk & "," & rg.Value
Next
s = Mid(wk, 2)
End If
MyList = Split(s, ",")
On Error Resume Next
pos = WorksheetFunction.Match(GetV, MyList, 0)
If Err.Number <> 0 Then
pos = 0
End If
On Error GoTo 0
pos = pos - 2
If pos <= 0 Then
pos = 0
End If
Range("A1").Value = MyList(pos)
End Sub
'▼ボタンのクリックイベント
Private Sub btnUp_Click()
Dim GetV As String
Dim MyList As Variant
Dim pos As Integer
Dim s As String
Dim wk As String
Dim rg As Range
GetV = Range("A1").Value
s = Range("A1").Validation.Formula1
If Left(s, 1) = "=" Then
wk = ""
For Each rg In Range(Mid(s, 2))
wk = wk & "," & rg.Value
Next
s = Mid(wk, 2)
End If
MyList = Split(s, ",")
On Error Resume Next
pos = WorksheetFunction.Match(GetV, MyList, 0)
If Err.Number <> 0 Then
pos = 0
End If
On Error GoTo 0
If pos >= UBound(MyList) Then
pos = UBound(MyList)
End If
Range("A1").Value = MyList(pos)
End Sub
リストの内容を表示するコマンドは見つける事ができませんでした。
ただ、下記の記述でリストの内容を表示する事は可能でした。
SendKeys "%{DOWN}"
次にマクロをキーボードのキーに登録する件ですが、
通常ではCtrlキー+アルファベットにしか登録できません。
また、上記の記述の場合、Ctrlキー+アルファベットで登録を
行ってもリストを表示する事は出来ませんでした。
(単に[Alt]+[↓]を送信しているだけなので、直前に入力された
[Ctrl]+アルファベットと重なってしまうものと思われます)
試しに1秒ウェイトを入れればリストが表示される事を確認しました。
Application.Wait Now + TimeValue("0:00:01") SendKeys "%{DOWN}"
1秒未満のウェイトを入れる方法もあるのですが、それではリストが
表示されませんでした。(Kernel32のSleepを利用しましたが、
その方法だと1秒のウェイトでもリストは表示されませんでした)
以上、不明な点がありましたら返答でお知らせください。
URl必須と言う事で、あまり関係ありませんが...
ありがとうございました。勉強になります。でも、できればすぐ使えるVBA表記の方がうれしかったです。
>ボタンを押すたびにそのリスト内容をセルに表示し確認できるようにしたい
とのことですが、「ボタン」とは、キーボードの方向キーのことでしょうか?
それとも、マウスでクリックするボタン(コマンドボタン)のことでしょうか?
どちらか不明ですが、前者だとして回答します。
※もし、後者がご希望の場合は、
コメントでお知らせして頂ければ、その例も回答します。
【データの入力規制】でリストを入れたセルがA1だとすると、
次の様に書けば、セルを選択すると自動的にリストが表示されます。
あとは↑キーと↓キーで選択して、Enterキーで確定ですよね
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = ("$A$1") Then
SendKeys "%{DOWN}"
End If
End Sub
URLはダミーです。
http://q.hatena.ne.jp/1151587395
※Enterキーさえ押さない方法も考えましたが、
ちょっと技巧的なやり方なので、先ずはオーソドックすなものを回答しました。
ご希望であれば、Enterキーが不要な方法も回答します。
ありがとうございました。
マウスでクリックする方法を知りたいです。できれば、最初の方と同様、activecellに対して行えれば、幸いです。
'アクティブセルに対して、処理を行いたいとのことでしたので、修正してみました。
'▲(上)ボタンを配置して、下記クリックイベントを割り当てます。
'▼(下)ボタンを配置して、下記クリックイベントを割り当てます。
'【使い方】
'入力規則(リスト)が設定されているセルをクリック(アクティブに)します。
'▲(上)または▼(下)ボタンを押すと、リストの表示内容が変化します。
'入力規則(リスト)が設定されているセルがアクティブになっていない場合は、ボタンを押しても何も起こりません。
'▲ボタンのクリックイベント
Private Sub btnDown_Click()
Dim GetV As String
Dim MyList As Variant
Dim pos As Integer
Dim s As String
Dim wk As String
Dim rg As Range
'アクティブセルが入力規則(リスト)で無い場合は終わり
On Error Resume Next
If ActiveCell.Validation.Type <> xlValidateList Then
Exit Sub
End If
If Err.Number <> 0 Then
Exit Sub
End If
On Error GoTo 0
GetV = ActiveCell.Value
s = ActiveCell.Validation.Formula1
If Left(s, 1) = "=" Then
'リストの内容がセル範囲指定の場合の対応
wk = ""
For Each rg In Range(Mid(s, 2))
wk = wk & "," & rg.Value
Next
s = Mid(wk, 2)
End If
MyList = Split(s, ",")
'現在表示中の項目位置を検索
On Error Resume Next
pos = WorksheetFunction.Match(GetV, MyList, 0)
If Err.Number <> 0 Then
pos = 0
End If
On Error GoTo 0
'次に表示する項目をセット
pos = pos - 2
If pos <= 0 Then
pos = 0
End If
ActiveCell.Value = MyList(pos)
End Sub
'▼ボタンのクリックイベント
Private Sub btnUp_Click()
Dim GetV As String
Dim MyList As Variant
Dim pos As Integer
Dim s As String
Dim wk As String
Dim rg As Range
'アクティブセルが入力規則(リスト)で無い場合は終わり
On Error Resume Next
If ActiveCell.Validation.Type <> xlValidateList Then
Exit Sub
End If
If Err.Number <> 0 Then
Exit Sub
End If
On Error GoTo 0
GetV = ActiveCell.Value
s = ActiveCell.Validation.Formula1
If Left(s, 1) = "=" Then
'リストの内容がセル範囲指定の場合の対応
wk = ""
For Each rg In Range(Mid(s, 2))
wk = wk & "," & rg.Value
Next
s = Mid(wk, 2)
End If
MyList = Split(s, ",")
'現在表示中の項目位置を検索
On Error Resume Next
pos = WorksheetFunction.Match(GetV, MyList, 0)
If Err.Number <> 0 Then
pos = 0
End If
On Error GoTo 0
'次に表示する項目をセット
If pos >= UBound(MyList) Then
pos = UBound(MyList)
End If
ActiveCell.Value = MyList(pos)
End Sub
もう完璧です。たびたびありがとうございました。
●前回の回答の修正版(アクティブセル対応版)は、次のとおりです。
Private Sub Worksheet_SelectionChange(ByVal Target As Range) On Error GoTo Fin If Selection.Validation.Type = xlValidateList And Selection.Validation.InCellDropdown Then SendKeys "%{down}" End If Fin: End Sub
●上記でも、クリックだけで操作できますが、ご希望ですので、コマンドボタン対応版も作ってみました。
コマンドボタンを2つ用意し、プロパティーを次のように変更します。
オブジェクト名:cmdPrev
Caption:▲
TakeFocusOnClick:False
オブジェクト名:cmdNext
Caption:▼
TakeFocusOnClick:False
VBAのコードは次のとおりです。
Private Sub cmdNext_Click() Call ValidValue(1) End Sub
Private Sub cmdPrev_Click() Call ValidValue(-1) End Sub
Private Sub cmdNext_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Call ValidValue(1) End Sub
Private Sub cmdPrev_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Call ValidValue(-1) End Sub
Private Sub ValidValue(Offset As Integer) Dim List, NewPos As Integer, TmpPos As Integer, TmpStr As String On Error GoTo Fin If Not Selection.Validation.Type = xlValidateList Then Exit Sub List = MakeList(Selection.Validation.Formula1) NewPos = LBound(List) For TmpPos = LBound(List) To UBound(List) TmpStr = Selection.Value If List(TmpPos) = TmpStr Then NewPos = TmpPos + Offset Exit For End If Next TmpPos If NewPos < LBound(List) Then NewPos = LBound(List) If NewPos > UBound(List) Then NewPos = UBound(List) Selection.Value = List(NewPos) Fin: End Sub
Function MakeList(sFormula) As Variant If Left(sFormula, 1) <> "=" Then MakeList = Split(sFormula, ",") Exit Function End If Dim L() As String, Item As Variant, Area As Range, i As Integer Set Area = Range(Mid(sFormula, 2)) ReDim L(Area.Cells.Count - 1) For Each Item In Area L(i) = Item i = i + 1 Next MakeList = L End Function
いかがでしょうか?
これまた完璧です。助かりました。ほんと皆さん、凄いですね。
凄いです。完璧です。ありがとうございました。できればでいいのですが、A1セルなどの固定セル指定ではなくactivecellで、できないでしょうか?記述を直すとエラーになってしまいます。