エクセルVBAで入力フォームを作成し、検索を行う方法

前へ 次へ
このQ&Aのポイント
  • エクセルVBAを使用して入力フォームを作成し、そのフォームで検索を行う方法を説明します。
  • フォームで検索を行う際、一度表示したデータが再検索時に表示される問題についても解決方法を紹介します。
  • VBA初心者でも理解しやすいように、具体的なコードや手順を説明します。
回答を見る
  • ベストアンサー

エクセル　ＶＢＡで入力フォームを作成し、そのフォームで検索をしようとF

エクセル　ＶＢＡで入力フォームを作成し、そのフォームで検索をしようとFindを使って動かしたのですが、一度表示したあと、再度別の値で検索しても最初に検索したデータが表示されてしまいます。 色々調べましたが、全く分からずこちらに質問しました。VBAは全くの初心者で本やHPを見ながら作っています。勉強不足なのは承知しております。どなたかご親切な方のご指導をお待ちしています。 顧客名　　　・・・・・・・・・・・ 店舗名　　　・・・・・・・・・・・ 略称　　　　・・・・・　　←ここに入力して検索をクリックします。 ・ ・ Private Sub 検索_Click() Dim w As Variant Dim r As Range ActiveSheet.Unprotect w = 略称.Value If w = "" Then Exit Sub Set r = Cells.Find(What:=w, After:=ActiveCell, LookIn:=xlValues, LookAt:= _ xlPart, SearchOrder:=xlByRows, MatchCase:=False _ , MatchByte:=False, SearchFormat:=False) If TypeName(r) = "Range" Then 略称.Value = Cells(ActiveCell.Row, 2).Value 顧客名.Value = Cells(ActiveCell.Row, 3).Value 店舗名.Value = Cells(ActiveCell.Row, 4).Value 締日.Value = Cells(ActiveCell.Row, 5).Value 売単価.Value = Cells(ActiveCell.Row, 6).Value サイクル.Value = Cells(ActiveCell.Row, 7).Value 郵便番号.Value = Cells(ActiveCell.Row, 8).Value 住所.Value = Cells(ActiveCell.Row, 9).Value 電話番号.Value = Cells(ActiveCell.Row, 10).Value FAX.Value = Cells(ActiveCell.Row, 11).Value 担当者.Value = Cells(ActiveCell.Row, 12).Value End If ActiveSheet.Protect End Sub

  • souba
  • お礼率60% (6/10)

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

何となくですが、、、 ソースを見る限り、初回の検索もうまくいっていないのような。。。。 Set r = Cells.Find( は、検索結果に該当するセルを「取得するだけ」の処理で、カーソルは移動しません。 なので、検索前と検索後では「ActiveCell」は同じはずです。 検索結果が存在しない場合もあります。 Findメソッド発行後に If r Is Nothing Then 　　ActiveSheet.Protect 　　 　　'検索結果なし 　　Call MsgBox("検索結果なし") 　　Exit Sub End If を追加しておきましょう。 そして、 　If TypeName(r) = "Range" Then って、これ 　Dim r As Range と宣言しているから、常にTrueだと思うので意味がない分岐かも？ あと 　略称.Value = Cells(ActiveCell.Row, 2).Value 　～ 　担当者.Value = Cells(ActiveCell.Row, 12).Value はActiveCellを利用していますよね？ なので、値を読み取る前に 　r.Activate として発行するか 　略称.Value = Cells(r.Row, 2).Value 　～ 　担当者.Value = Cells(r.Row, 12).Value のように、カーソル位置を変えずに、検索結果のRangeを利用する必要があるかもです。 ※Findメソッド (特に引数Afterの意味) ※FindNextメソッド の理解を高めると、うまくいくと思いますよ。

souba
質問者

お礼

早速、やってみました。 略称.Value = Cells(r.Row, 2).Value でうまくいきました。 有難うございます。 ご指摘の通り勉強不足で理解してからやるべき とも思うのですが、出来たらいいなではなく、 やらないとならないものでしたので。 大変助かりました、有難うございました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • エクセルＶＢＡで最小値を求めたいのですが

    下記はある表の最大値を求めるものですが 同様の条件で最小値を求めようと思い 「MAX」の箇所を「MIN」差し替えてできると思っていたのですが 最小値がのかわりに「0」が表示されてしまいます。 そのように修正すればよいでしょうか？ private sub worksheet_change(byval Target as excel.range) 　if target.cells(1) = "" then exit sub 　if target.address = "$A$1" then 　　Range("C10:C65536").ClearContents 　　With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) 　　　.FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" 　　　.Value = .Value 　　End With 　elseif target.address = "$E$1" then 　　Range("G10:G65536").ClearContents 　　With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) 　　　.FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" 　　　.Value = .Value 　　End With 　end if end sub

  • エクセルＶＢＡについて

    http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを Ｅ列に日付 Ｆ列に売上 Ｇ列に結果 でやりたいのですが この時Ａ列～Ｃ列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか？

  • Excel VBA テキストボックスを検索

    テキストボックス３に数値を入力し ExcelのA列にあるか検索をかける。 ある場合は、B列の同じ行に 「みーつけた！」と入力。 その設定で組んでみたのですが、 テキストボックス３にデータを6桁入力しようとすると 6桁目にオーバーフローエラーが出ます。 このプログラムの何処がおかしいのでしょうか？ Private Sub TextBox3_Change() Dim Number As Integer If TextBox3.Value <> "" Then '空じゃない場合 Number = TextBox3.Value Call 検索(Number) MsgBox TextBox3.Value End If End Sub Sub 検索(ByVal Number As Variant) Dim FoundCell As Range Set FoundCell = Range("A:A").Cells.Find(What:=Number, lookat:=xlPart) If FoundCell Is Nothing Then Else FoundCell.Activate Range("O" & ActiveCell.Row).Value = "みーつけた！" End If End Sub

  • エクセル　マクロ　検索

    お世話になります。 範囲がA2からK221までの表があります。 検索して検索されたセルの左のセルを表示するマクロを組みたいのですが、検索する文字（数値）はE1に、検索結果はK1に表示するようにするにはどのようにしたらいいでしょうか？ Sub FIND_DATA1() ' FIND_DATA1 Macro ' マクロ記録日 : 2006/9/1 ユーザー名 : ' Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole).Activate End Sub Sub Data_Find3() Dim 対象セル As Range Dim 最初のセル番地 As String Dim 検索件数 As Long Cells.Interior.ColorIndex = xlNone If Range("E1").Value = "" Then Exit Sub End If Set 対象セル = Cells.Find(What:=Range("E1").Value, After:=ActiveCell, lookAt:=xlWhole) 最初のセル番地 = 対象セル.Address Do 対象セル.Interior.ColorIndex = 37 検索件数 = 検索件数 + 1 Set 対象セル = Cells.FindNext(対象セル) Loop While 対象セル.Address <> 最初のセル番地 MsgBox "検索件数は" & 検索件数 - 1 & " 件です" End Sub 本を見たり調べたりでここまでできたんですがこれだと検索件数、検索結果が色付きになるだけで使い勝手がいまいちです。 よろしくお願いします。

  • エクセルVBA　VLOOKUPについて

    エクセル　VBA初心者です。 関数でのVLOOKUPをVBAで作りたいのですが、上手くいきません。 あらかじめ、Sheet2の1から300行までに A列　 / B列 商品名 / 商品コード が入力されています。(名前の定義=商品コード) Sheet1にユーザーフォームを利用して、データを書き込んだ後、 B列に商品名が書き込まれると、 A列に商品コードが表示されるようにしたいと考えています。 A列に =IF(B2="","",VLOOKUP(B2,商品コード,2,FALSE)) と入力していたのですが、 VBAでIfを使って出来ないかと考えてみたのですが、 上手くいきませんでした。 Private Sub Worksheet_Change(ByVal Target As Range) Dim sRow As Long Dim sColumn As Long sRow = ActiveCell.Row sColumn = ActiveCell.Column If Cells(sRow, 2).Value = True Then Cells(sRow, 1).Value = WorksheetFunction.VLookup(Cells(sRow2).Value, Worksheets("Sheet2").Range("A1:B300"), 2, False) ElseIf Cells(sRow, 2).Value = " " Then Cells(sRow, 1).Value = " " End If End Sub ご教授いただけないでしょうか？ エクセル2003 WindowsXP

  • VBAのファインドメソッドで検索すると対象外のデータが選択されることがある

    CDのリスト表（12列で、現在2269行 範囲名"収録表"）Sheets("データ")から,キーワードで該当ディスクを検索し、 結果をSheets("検索")に転記する、プログラムを作りましたが、 仮に、該当データが10件、転記されたとして そのデータを見ると、中に1件、対象外のデータがはいっている事が たまにあります、いろんな原因を考えてみましたがわかりません。 もともと、VBAのファインドメソッドが、こんなエラーを起こしやすいのか、、、（そんな事、ないよね） どなたか、教えてください。 下が、プログラムです Sub 新規検索() Application.ScreenUpdating = False Dim myData, myRng As Range Dim myWord As String myWord = InputBox("キーワードを入力してください") データ処理中F.Show vbModeless データ処理中F.Repaint Set myData = Range("収録表") Set myRng = myData.Find(What:=myWord, LookIn:=xlValues, _ Lookat:=xlPart, MatchCase:=False, MatchByte:=False) If myWord = "" Then MsgBox ("キーワードを入力してください") Exit Sub End If If Not myRng Is Nothing Then Application.Goto Cells(myRng.Row, 1), True Else: Unload データ処理中F MsgBox ("該当データはありません") Exit Sub End If Sheets("検索").Range("K1") = myRng.Row '一番最初の検索値のRow Call コピー1 Do Until Range("K1") = Range("L1") 　 Call 次を検索 Loop Call 検索終了 Unload データ処理中F Application.ScreenUpdating = True End Sub Sub 次を検索() Dim myData, myRng As Range Sheets("データ").Select Set myData = Range("収録表") Set myRng = Cells.FindNext(after:=ActiveCell.Offset(1)) If myRng <> "" Then Application.Goto Cells(myRng.Row, 1), True End If Sheets("検索").Range("L1") = myRng.Row '2番目以降の検索値のRow 　 Call コピー2 End Sub Sub コピー1() Sheets("検索").Range("A3:L5000,L1").ClearContents Dim myData As Range Set myData = Range("収録表") Set motorng = Application.Intersect(myData, ActiveCell.EntireRow) Set sakiRng = Sheets("検索").Range("A65535").End(xlUp).Offset(1) motorng.Copy sakiRng Sheets("検索").Visible = True Sheets("検索").Activate End Sub Sub コピー2() Dim myData As Range Set myData = Range("収録表") Set motorng = Application.Intersect(myData,　　　ActiveCell.EntireRow) Set sakiRng = Sheets("検索").Range("A65535").End(xlUp).Offset(1) motorng.Copy sakiRng Sheets("検索").Visible = True Sheets("検索").Activate End Sub Sub 検索終了() Dim r As Long r = Range("A65536").End(xlUp).Row Range("A" & r).Select ActiveCell.FormulaR1C1 = "=COUNTA(R3C:R[-1]C)" MsgBox "全部で" & Range("A" & r).Value & "件ありました" Range("A65535").End(xlUp).EntireRow.ClearContents Call 行頭表示 End Sub

  • VBAを使って検索をしたい

    VBAを使って検索をしたい EXCEL２００７を使っております。 フォームを立ち上げて日付を入れるとシートの検索を行い、リスト内にその日付のA～Ｇまでのセルの内容が表示され、それらを別シートに貼り付けるといったことをしたいのですが、複数のセルの情報をリスト内に表示をするのが、よくわからず教えていただきたく思います。 フォーム内のテキストボックスに検索する日付を入れると 画像でいうところのA列を検索し、その日付内のA～Gをリストに表示して、ボタンを押すと貼り付けるといった、動きにしたいのですが、お願いします。 現状検索ＢＯＸに以下の記述をしてます これでは、Ａ列のものだけが出てきます。お助けください。 ＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊ Private Sub TextBox1_Change() Dim r As Range, FirstCell As Range, rng As Range Dim vnt As Variant Dim prow As Long Dim s As Worksheet Dim cnt As Long Set s = Sheets("sheet2") Set rng = Intersect(s.Range("a:a"), s.UsedRange) '検索キー Set r = rng.Find(What:=TextBox1.Text) If r Is Nothing Then MsgBox "見つかりませんよ" GoTo Exit_sub End If Set FirstCell = r ReDim vnt(0) vnt(0) = s.Cells(r.Row, 1).Resize(1, 5).Value '検索位置 prow = r.Row cnt = 1 Do Set r = rng.FindNext(r) If Not r Is Nothing And (r.Address <> FirstCell.Address) _ And (FirstCell.Row <> r.Row) And (prow <> r.Row) Then ReDim Preserve vnt(UBound(vnt) + 1) vnt(UBound(vnt)) = s.Cells(r.Row, 1).Resize(1, 5).Value '検索位置 prow = r.Row cnt = cnt + 1 End If Loop While r.Address <> FirstCell.Address ' If cnt = 1 Then vnt = s.Cells(FirstCell.Row, 1).Resize(1, 5).Value '検索位置 If cnt > 1 Then vnt = Application.Transpose(Application.Transpose(vnt)) ListBox1.List = vnt ' Set FirstCell = Nothing Erase vnt Exit_sub: If cnt = 0 Then ListBox1.Clear Set r = Nothing Set rng = Nothing Set s = Nothing End Sub

  • 文字を入力したセル以降のセルも同じ文字になるVBA

    Private Sub Worksheet_Change(ByVal Target As Range) Dim R As Range ActiveSheet.Protect UserInterfaceOnly:=True Set R = Union(Range("D5:D38"), Range("E5:E38"), Range("T5:T38")) With Target If Intersect(.Cells, R) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(.Row, .Column), Cells(38, .Column)).Value = .Value Application.EnableEvents = True End With End Sub この様なコードがあるのですが範囲を変更したいと思います。 D５：D38は上記コードのままで良いのですが、E5；E38はE5：E36に、T5：T38はT5：T36に変更するにはどうすれば良いのでしょうか？

  • 　VBA　表作成で内容を最下行で入力した場合　自動で次の行の作成を行いたい。

    VBAで質問です。　　Excel2003 最下行を検索し、そこの内容部分を入力された場合、1行あたらしく 式、罫線をコピーしたいのですがずっとループを起こしてしまいます。 直し方を教えていただきたいです。 ソース Private Sub Worksheet_Change(ByVal Target As Range) '------------------------------------ '変数の宣言 '------------------------------------ Dim naiyou As Object Dim bikou As Object Dim xline As Integer Dim yline As Integer Dim count As Integer Dim startrow As Integer Dim maxcolumn As Integer '------------------------------------ '内容＝D4の列検索 '------------------------------------ Set naiyou = ActiveSheet.Cells.Find("内容") xline = naiyou.Column '------------------------------------ '表示している最終行の検索 '------------------------------------ startrow = 4 count = Cells(startrow, xline).End(xlDown).Row '------------------------------------ '備考の＝I4列検索 '------------------------------------ Set bikou = ActiveSheet.Cells.Find("備考") yline = bikou.Column '------------------------------------ 'コピペ処理 '------------------------------------ If ActiveSheet.Cells(count, 4) <> "" Then Range(Cells(count + 1, 1), Cells(count + 1, yline)).Select Selection.Copy Range(Cells(count + 2, 1), Cells(count + 2, yline)).Select ActiveSheet.Paste Application.CutCopyMode = False Exit Sub Else: End If End Sub

  • VBAでのエラー対処について

    現在仕事でVBAと悪戦苦闘しています。 下記のマクロを実行すると、実行時エラー'13':型が一致しません。 と表示されます。 初心者で対処法がわかりません。 よろしくお願いします。 Sub Macro1() dat = InputBox("検索値") Range("A1").Activate Cells.Find(What:=dat, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _ , MatchByte:=False, SearchFormat:=False).Activate gegyo = ActiveCell Do Cells.FindNext(After:=ActiveCell).Activate If dat = ActiveCell Then If gegyo = ActiveCell.Row Then End Rows(ActiveCell.Row - 1 & ":" & ActiveCell.Row - 1).Delete Shift:=xlUp Range("A" & ActiveCell.Row - 1).Activate Rows(ActiveCell.Row + 1 & ":" & ActiveCell.Row + 1).Delete Shift:=xlUp Rows(ActiveCell.Row & ":" & ActiveCell.Row).Delete Shift:=xlUp End If gegyo = ActiveCell.Row Loop End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する