ご指導願います。
VBAで以下の機能を作りたいと考えています。
 1.任意のセルをマウスで指す
 2.セル横に▼が表示され,”東京”と”大阪”が表示される
 3.どちらか選択した方がセルに格納される
 以上の機能を入力規則や,フォームツールボックスなどで,VABを使わずに作ることはできます。
 VBAで東京や大阪といった項目を設定し,任意のセル横に▼を表示したりする方法ご指導願いたいと存じます。よろしくお願い致します。

このQ&Aに関連する最新のQ&A

A 回答 (3件)

Sheet1で行う例です。



VBAのコントロールツールボックスからSheet1にコンボボックスを1つ作ります。
混乱をきたすとまずいので、オブジェクト名などは初期値のままとします。
(オブジェクト名は初期値のComboBox1とします)高さ、幅は適当に調整して下さい。

『東京、大阪』をどのように設定すればいいか明言されていないので、数も2つだし
コンボボックスを表示する時にセットしています。
ListFillRangeプロパティで事前に設定していれば、If~End Ifは不要になります。
例えば、セルA1=東京、A2=大阪にしてListFillRangeをA1:A2にするような感じです。
実質3行で終わっています。
Sheet1全体で入力ができるのもおかしいので、B列のみこの操作ができるようにしてあります。
テキトーに修正して下さい。

ツール→マクロ→Visual Basic Editor でVBE画面に移り、Sheet1のコードウインドウに貼り付けます。

ここから

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  With ComboBox1
    If Target.Column = 2 Then   'B列(Column=2)なら表示する例
      .Visible = True
      If .ListCount <> 2 Then  'クリックの都度Listを決めている
        .Clear
        .AddItem "東京"
        .AddItem "大阪"
      End If
      .Top = Target.Offset(0, 1).Top   '縦位置を決める
      .Left = Target.Offset(0, 1).Left  '横位置を決める
      .LinkedCell = Target.Address    'リンクするセルを決める
    Else
      .Visible = False
    End If
  End With
End Sub
    • good
    • 0
この回答へのお礼

うまくできました。
ありがとうございました。

お礼日時:2002/04/12 14:43

「セルに内容をセットしたい」との希望がよせられたので、上の2つのドロップダウンのクリックした項目内容をセルにセットする方法を載せます。


-------
1番上のドロップダウンの所へカーソルを置いて、マウスの右クリック
を押す。「マクロ登録」をクリック。「新規作成」をクリック。
Sub ドロップ1_Change()

End Subと現れるから、SubとEndSubの間に下記を貼りつける。
「実行」し、ワークシートに帰り、ドロップダウンの▼をクリックして
好きな項目を選択すると、セルに、ドロップダウンで選んだ項目が出る。
-------
Sub ドロップ1_Change()
ary1 = Array("", "東京", "大阪", "名古屋", "仙台")
a = ActiveSheet.DropDowns(1).ListIndex
Worksheets("sheet1").Range("a4") = ary1(a)
End Sub
Sub ドロップ2_Change()
ary1 = Array("", "夏", "秋", "冬", "春")
a = ActiveSheet.DropDowns(2).ListIndex
Worksheets("sheet1").Range("a6") = ary1(a)
End Sub
------
LinkedCellの場合はListIndexの数字しか現われないが、このような似た設定で項目内容が出せる設定があったように思いますが、思い出せないので取りあえず上記のようにして見ました。ListやListIndex辺りを調べればわかるかも。
    • good
    • 0
この回答へのお礼

たびたびのご指導ありがとうございました。
たいへん勉強になりました。

お礼日時:2002/04/19 18:28

下記の様なのはいかがですか。


AddItemのところを簡略にしたかったんですが取りあえず載せます。
Sub test01()
Dim n(10)
ll = Worksheets("sheet1").Cells(3, 3).Left
tt = Worksheets("sheet1").Cells(3, 3).Top
ww = Worksheets("sheet1").Cells(3, 3).Width
hh = Worksheets("sheet1").Cells(3, 3).Height
k = 1
For i = 1 To 10 Step 2
With Worksheets("sheet1")
Set cb = .Shapes.AddFormControl(xlDropDown, ll, tt + hh * i, ww, hh)
n(k) = cb.Name
' cb.ControlFormat.LinkedCell = "A" & Trim(Str(2 + 2 * k))
k = k + 1
End With
Next i
Worksheets("sheet1").DropDowns(n(1)).AddItem ("東京")
Worksheets("sheet1").DropDowns(n(1)).AddItem ("大阪")
Worksheets("sheet1").DropDowns(n(1)).AddItem ("名古屋")
Worksheets("sheet1").DropDowns(n(1)).AddItem ("福岡")
'---------
Worksheets("sheet1").DropDowns(n(2)).AddItem ("夏")
Worksheets("sheet1").DropDowns(n(2)).AddItem ("秋")
Worksheets("sheet1").DropDowns(n(2)).AddItem ("冬")
Worksheets("sheet1").DropDowns(n(2)).AddItem ("春")
'---------
Worksheets("sheet1").DropDowns(n(3)).AddItem ("男")
Worksheets("sheet1").DropDowns(n(3)).AddItem ("女")
Worksheets("sheet1").DropDowns(n(3)).AddItem ("子供")
Worksheets("sheet1").DropDowns(n(3)).AddItem ("老人")
'---------
Worksheets("sheet1").DropDowns(n(4)).AddItem ("10代")
Worksheets("sheet1").DropDowns(n(4)).AddItem ("20代")
Worksheets("sheet1").DropDowns(n(4)).AddItem ("30代")
Worksheets("sheet1").DropDowns(n(4)).AddItem ("40代")
'---------
Worksheets("sheet1").DropDowns(n(5)).AddItem ("大卒")
Worksheets("sheet1").DropDowns(n(5)).AddItem ("高卒")
Worksheets("sheet1").DropDowns(n(5)).AddItem ("短大卒")
Worksheets("sheet1").DropDowns(n(5)).AddItem ("院卒")
End Sub
    • good
    • 0
この回答へのお礼

ご指導ありがとうございます。
DropDownの入力結果をセルに入力することはできるのでしょうか。

お礼日時:2002/04/15 18:13

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q任意のセルを検索窓にして文字(ひらがな)を入力すると既記入のセルを探しそのセルの横のセルに飛びたい

当方、エクセル2013 です。ほとんど初心者です。
表題のような事って出来るでしょうか?いちいちマウスを使うこと無く出来れば良いなと思っております。
画像で言いますとA1に「かけふ」といれるとD5に飛び、ここに数字を入れると又、勝手にカーソルがA1に戻る。って出来ないでしょうか?教えて下さい。

Aベストアンサー

こんばんは!
VBAでの操作になりますが、一例です。

画面左下の操作したいSheet見出し上で右クリック → コードの表示 → VBE画面のカーソルが点滅しているところに
↓のコードをコピー&ペースト → Excel画面に戻り(VBE画面を閉じて)
A1セルにデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から//
Dim c As Range
If Intersect(Target, Union(Range("A1"), Range("D:D"))) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target
If .Column = 1 Then
If .Value <> "" Then
Set c = Range("C:C").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Offset(, 1).Select
Else
MsgBox "Not Found"
.Select
End If
End If
Else
If IsNumeric(.Value) Then
Range("A1").Select
Selection.ClearContents
Else
MsgBox "数値を入力してください"
.Select
End If
End If
End With
End Sub 'この行まで//

こんな感じではどうでしょうか?m(_ _)m

こんばんは!
VBAでの操作になりますが、一例です。

画面左下の操作したいSheet見出し上で右クリック → コードの表示 → VBE画面のカーソルが点滅しているところに
↓のコードをコピー&ペースト → Excel画面に戻り(VBE画面を閉じて)
A1セルにデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から//
Dim c As Range
If Intersect(Target, Union(Range("A1"), Range("D:D"))) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target
...続きを読む

QVBA あるセルの内容と同じ内容のセルを検索してその横のセルをコピーして貼り付ける

VBAの質問です。
Sheet1のA2のセルと同じ文字列をSheet2のB列で検索し、検索された同じ文字列のセルの右隣をSheet1のA4にコピー貼り付け、同じ文字列のセルの2つ右隣~4つ右隣のセルまでをB2~B4に縦と横を入れ替えてコピーし貼り付けたい。
宜しくお願いします。

Aベストアンサー

こんばんは!

なかなか回答が付かないようなので・・・
Sheet2のB列に重複データはないという前提です。

Sub Sample1()
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
Set c = wS.Range("B:B").Find(what:=.Range("A2"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Range("A4") = c.Offset(, 1)
c.Offset(, 2).Resize(, 3).Copy
.Range("B2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End If
End With
End Sub

こんな感じではどうでしょうか?m(_ _)m

こんばんは!

なかなか回答が付かないようなので・・・
Sheet2のB列に重複データはないという前提です。

Sub Sample1()
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
Set c = wS.Range("B:B").Find(what:=.Range("A2"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Range("A4") = c.Offset(, 1)
c.Offset(, 2).Resize(, 3).Copy
.Range("B2").PasteSpecial ...続きを読む

QEXCEL(エクセル)で、シート上のすべての任意アルファベットの横に一桁の任意数字があるセルを変換したい

EXCEL(エクセル)で、シート上のすべての任意アルファベットの横に一桁の任意数字があるセルを、次に示すセルに変換する方法を教えていただけないでしょうか。(\d一桁の任意数字\n)の横に上記の任意アルファベットがあるセル。実際には()はつけないでください。
例、
H2Oを、H\d2\nOに置換。
O2を、O\d2\nに置換。

ただし、数式のセルは変更しないようにしてください。
よろしくお願いいたします。

Aベストアンサー

#01です。このようなマクロになるかと思います。
もう少し整理すればスッキリすると思いますが、それは質問者さまが自由に手を入れてください。

Option Explicit
Sub Macro3()
Dim RE, strPattern, repPattarn, trgStr As String
Dim r As Range, i As Integer, mchItem
Set RE = CreateObject("VBScript.RegExp")
strPattern = "[A-Z]\d"
With RE
.Pattern = strPattern ''検索パターンを設定
.IgnoreCase = True ''大文字と小文字を区別しない
.Global = True ''文字列全体を検索
For Each r In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants, 3)
trgStr = r.Formula
Set mchItem = .Execute(trgStr)
If mchItem.Count > 0 Then
For i = mchItem.Count - 1 To 0 Step -1
repPattarn = Left(mchItem(i).Value, 1) & "\d" _
& Right(mchItem(i).Value, 1) & "\n"
If Len(trgStr) - 2 = mchItem(i).FirstIndex Then
trgStr = Left(trgStr, Len(trgStr) - 2) & repPattarn
Else
trgStr = Left(trgStr, mchItem(i).FirstIndex) & repPattarn _
& Right(trgStr, Len(trgStr) - mchItem(i).FirstIndex - 2)
End If
Next i
r.Formula = trgStr
End If
Next r
End With
Set RE = Nothing
End Sub

#01です。このようなマクロになるかと思います。
もう少し整理すればスッキリすると思いますが、それは質問者さまが自由に手を入れてください。

Option Explicit
Sub Macro3()
Dim RE, strPattern, repPattarn, trgStr As String
Dim r As Range, i As Integer, mchItem
Set RE = CreateObject("VBScript.RegExp")
strPattern = "[A-Z]\d"
With RE
.Pattern = strPattern ''検索パターンを設定
.IgnoreCase = True ''大文字と小文字を区別しな...続きを読む

Qエクセルで同じA列の中に、1,2,3,4,5,6,2,3,4,2,1,3,2,2,2,3,1という

エクセルで同じA列の中に、1,2,3,4,5,6,2,3,4,2,1,3,2,2,2,3,1,3,1というような順番で数字が並んでいます。

その数字の中で、1→3と3→1になるものがいくつあるか求めたいのですが、出す関数・マクロがわかりません。
教えていただけないでしょうか?

よろしくお願いします。

Aベストアンサー

こんばんは!

>A列の中に
とは行方向に数値が入っている!というコトでしょうか?

そうであれば
表示したいセルに
=COUNTIFS(A1:A1000,1,A2:A1001,3)+COUNTIFS(A1:A1000,3,A2:A1001,1)
としてみてください。

「1」の次の行が「3」の場合と
「3」の次の行が「1」の場合をプラスしています。m(_ _)m

QEXCEL2000で「01,02」や「03,05」と入ったセルを「1,2」や「3,5」のように数字の前の0を消したい。

過去の質問も調べてみましたが、見当たりませんでしたので質問させてください。

エクセルのデータで、セル内に「01,02,04,06」や「02,08,10」と
いったような数字が入っていますが、
実際には数字の前の0(ゼロ)が不要で、最終的には「1,2,4,6」や
「2,8,10」のようにしたいのですが、やり方がわかりません。

どなたか方法がお分かりになる方がいらっしゃいましたら、
どうぞ教えてください。
よろしくお願いします。

Aベストアンサー

=SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,"0","",1),",0",","),",,",",0,")

解説(最後の部分が必要ないなら数式から外してください。)
SUBSTITUTE(A1,"0","",1) => 先頭の0のみを消します
「01,02,04,0,06」=>「1,02,04,0,06」
SUBSTITUTE(上記の結果,",0",",") =>後続の,の後の0を消します
「1,02,04,0,06」=>「1,2,4,,6」
SUBSTITUTE(上記の結果,",,",",0,") =>内容が,0,の場合の誤消去を戻します。
「1,2,4,,6」=>「1,2,4,0,6」


人気Q&Aランキング

おすすめ情報