エクセルのVBAでお答えください。

Question

anglar

38

37もっと見る

170pt

コンピュータ

エクセルのVBAでお答えください。

一つのセルに【データの入力規制】でリストを入れています。その値をそのセル上で選ぶときは、ＡＬＴ＋↓で選びますよね。このことと同じことをマクロで、できますか？つまり、マクロを下矢印ボタンや上矢印ボタンに登録し、ボタンを押すたびにそのリスト内容をセルに表示し確認できるようにしたいのです。どなたか分かる方、お願いします。VBAの記述付きで。

回答の条件

URL必須
1人2回まで

登録：2006/06/29 22:23:18
終了：2006/07/04 18:43:17

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

コメントはまだありません

人力検索はてなエクセルのVBAでお答えください。一つのセ.. 2006-07-01 10:01:14

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

llusall · Answer 1 · 2006-06-30T12:35:11+09:00

'あまり綺麗でないのですが、いかがでしょうか？

'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

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

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

'http://www.yahoo.co.jp ダミー

gong1971 · Answer 2 · 2006-06-30T12:54:24+09:00

リストの内容を表示するコマンドは見つける事ができませんでした。

ただ、下記の記述でリストの内容を表示する事は可能でした。

SendKeys "%{DOWN}"

次にマクロをキーボードのキーに登録する件ですが、

通常ではCtrlキー+アルファベットにしか登録できません。

また、上記の記述の場合、Ctrlキー+アルファベットで登録を

行ってもリストを表示する事は出来ませんでした。

(単に[Alt]+[↓]を送信しているだけなので、直前に入力された

[Ctrl]+アルファベットと重なってしまうものと思われます)

試しに1秒ウェイトを入れればリストが表示される事を確認しました。

Application.Wait Now + TimeValue("0:00:01")
SendKeys "%{DOWN}"

1秒未満のウェイトを入れる方法もあるのですが、それではリストが

表示されませんでした。(Kernel32のSleepを利用しましたが、

その方法だと1秒のウェイトでもリストは表示されませんでした)

以上、不明な点がありましたら返答でお知らせください。

URl必須と言う事で、あまり関係ありませんが...

http://homepage2.nifty.com/sak/w_sak3/doc/sysbrd/vb_v08.htm

nandedarou · Answer 3 · 2006-07-01T03:10:02+09:00

>ボタンを押すたびにそのリスト内容をセルに表示し確認できるようにしたい

とのことですが、「ボタン」とは、キーボードの方向キーのことでしょうか？

それとも、マウスでクリックするボタン（コマンドボタン）のことでしょうか？

どちらか不明ですが、前者だとして回答します。

※もし、後者がご希望の場合は、

コメントでお知らせして頂ければ、その例も回答します。

【データの入力規制】でリストを入れたセルが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キーが不要な方法も回答します。

llusall · Answer 4 · 2006-07-01T14:43:25+09:00

'アクティブセルに対して、処理を行いたいとのことでしたので、修正してみました。

'▲(上)ボタンを配置して、下記クリックイベントを割り当てます。

'▼(下)ボタンを配置して、下記クリックイベントを割り当てます。

'【使い方】

'入力規則(リスト)が設定されているセルをクリック（アクティブに）します。

'▲(上)または▼(下)ボタンを押すと、リストの表示内容が変化します。

'入力規則(リスト)が設定されているセルがアクティブになっていない場合は、ボタンを押しても何も起こりません。

'▲ボタンのクリックイベント

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

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

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

'http://www.yahoo.co.jp ダミー

nandedarou · Answer 5 · 2006-07-02T04:07:30+09:00

●前回の回答の修正版（アクティブセル対応版）は、次のとおりです。

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

●上記でも、クリックだけで操作できますが、ご希望ですので、コマンドボタン対応版も作ってみました。

コマンドボタンを２つ用意し、プロパティーを次のように変更します。

オブジェクト名：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

いかがでしょうか？

http://hatena.ne.jp/ ダミー

エクセルのVBAでお答えください。

回答（5件）

llusall505612006/06/30 12:35:11

gong1971451702006/06/30 12:54:24

nandedarou230342006/07/01 03:10:02

llusall505612006/07/01 14:43:25

nandedarou230342006/07/02 04:07:30

コメント（0件)

この質問への反応（ブックマークコメント）

トラックバック