• 締切済み

VBAのプロシージャの記述について

Sub データ検索() Dim myNo As Variant Dim mykekka As Range myNo = InputBox("機番Noを入力してください。", "機番No入力") Cells.Find(What:=myNo, LookAt:=xlPart).Select End Sub 上記のような検索のプロシージャを記述しました。 セルB(機番)を検索して該当の単一セルが選択されるまでは、記述出来たのですが、選択された単一セルの行(A~W)を取得して、下の空白の行にコピーしたいのですが、選択された単一セルの行(A~W)の取得の仕方が分かりません。 VBAを始めたばかりなので、質問の内容が分かりにくいかもしれませんがアドバイスよろしくお願いします。

noname#108190
noname#108190

みんなの回答

  • zap35
  • ベストアンサー率44% (1383/3079)
回答No.2

>下の空白の行にコピーしたいのですが、 これは、検索された機番Noの行の下という意味ですか? それとも検索された機番Noの行から下にある空白の行という意味ですか? その辺が明確でないので、とりあえず最後の行にコピーするようにしました。また全てのセルを検索範囲にすると無駄ですし誤動作の原因となりますから検索するは列は限定する方がよいと思います。さらに言えば実務で使うつもりならエラー処理は入れた方がよいですよ。質問のマクロだと検索して見つからなかったときエラーになります。 ですからあくまで参考程度にしてください。 Sub データ検索() Dim myNo As Variant Dim mykekka As Range Dim trg As Range Const KibanCol As Integer = 1 '列番号 1:A列、2:B列   myNo = Application.InputBox("機番Noを入力してください。", "機番No入力") 'メソッドのInputBoxを使いましょう   If TypeName(myNo) = "Boolean" Then 'Cancelのとき     MsgBox "Cancelが選択されました"   Else     Set trg = ActiveSheet.Columns(KibanCol).Find(What:=myNo, _             LookIn:=xlValues, LookAt:=xlPart) '機番Noの列を検索     If Not trg Is Nothing Then '検索した値が見つかったとき       ActiveSheet.Range(Cells(trg.Row, "A"), Cells(trg.Row, "W")).Copy _         Destination:=ActiveSheet.Cells(65536, KibanCol).End(xlUp).Offset(1, 0)     Else       Msgbox "機番Noが見つかりませんでした"     End If   End If End Sub

noname#108190
質問者

補足

質問へのアドバイス、有難う御座いました。 年末年始と、アドバイス頂いた内容をマニアル本を見ながら理解しようとしていたので、返事が遅くなり大変申し訳ありませんでした。 追加で質問したいのですが、新たに作成したシート(予定表)に検索した値をコピーしたいのですが、どのように記述すればいいでしょうか。 お礼が遅くなったうえに質問するのは申し訳ないのですが、アドバイスをお願いします。

noname#252806
noname#252806
回答No.1

ActiveCell.EntireRow.Select

noname#108190
質問者

お礼

質問への回答有難う御座いました。 お礼が遅くなり申し訳ありませんでした。 今後もよろしくお願いします。

関連するQ&A

  • Excel VBA でテキストボックスの値をセルA列から検索

    いつもお世話になります。 Private Sub CommandButton3_Click() Dim 行 As String Dim 列 As String Dim 最終行 As String Dim 検索行 As String Dim メッセージ As Integer Dim 一致 As Range Dim myNO As Variant Dim i As Long Sheets(3).Select 最終行 = Range("A2").End(xlDown).Offset(1).Select 行 = ActiveCell.Row 列 = ActiveCell.Column myNO = TextBox2.Value 検索行 = Range("A2").End(xlDown).Select ※・・・Set 一致 = Range("A2:検索検").Findwhat:=TextBox2,lookat:=xlWhole) If 一致 Is Nothing Then MsgBox "データがありません。新規コード入力します。" Cells(行, 列 + 0) = UserForm1.TextBox2.Value Cells(行, 列 + 1) = UserForm1.ComboBox7.Value Else i = Cells(行 - 1, "A") Cells(i, 列 + 0) = UserForm1.TextBox2.Value Cells(i, 列 + 1) = UserForm1.ComboBox7.Value End If End Sub 「エラー1004'Range'メソッドは失敗しました'Global'オブジェクト」とでます。※印が黄色になっています。 ユーザーフォーム1のテキストボックスの値をシート3のA列から検索して、一致すれば、A列の一致セルに上書き入力して、一致が無い場合はA列の空白セルに追加入力したいのです。よろしくお願い致します。

  • EXCEL VBAについて

    EXCEL VBAについて教えてください やりたいことは以下の通りです。 ・全シートJ列1~100行目を検索しアルファベットが含まれるセルが存在すれば 上のセルをコピーする ここまで作ったのですが上手くいきません Sub VBAsample() Dim GYO As Long For GYO = 1 To 100 If Find([a-z], LookAt:=xlPart) Then Cells(GYO, 10).Value = Cells(GYO - 1, 10).Value End If Next GYO End Sub 添削をお願いします

  • excel VBA 2つのプロシージャを1つに

    いつもお世話になっております。 初心者ですが、苦しみながらもexcelでデータベースを作成しております。 さて Worksheet_Change のイベントが2つあり、これを一つにまとめようとしているのですが、がんばっているんですが、自分ではどうしてもうまくいかない為、投稿させていただきました。 コードは下記2つです。 また、どういったものを作ろうとしているのか説明不足でご指摘を頂戴することもありますので、試作段階のファイルですが、アップローダーにあげさせていただきました。確認頂ければ幸いです。 ■アプロダ 投稿No 4514 http://www.kent-web.com/pubc/book/test/uploader/uploader.cgi ■作ろうとしているデータベースの概要 inputシート・・・データを直接入力して、また、データや写真を閲覧をするシート dataシート・・・データを格納するシート、オートフィルタを使って、曖昧検索フィルタもここでかけたりします。 どうか良いお知恵を拝借させていただきたくよろしくお願いします。 '一つ目のプロシージャ(Noセルに数字が入ると、そのNoのデータを自動的にdataシートまで読みにいって表示させます) Private Sub WorkSheet_Change(ByVal Target As Range) 'No入力してデータ反映 Dim fRange As Range Dim fRow As Long If Target.row <> 4 Then Exit Sub If Target.Column <> 3 Then Exit Sub Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then '見つからなかった? MsgBox "入力された顧客コードが存在しません。", vbExclamation Exit Sub End If fRow = fRange.row '検索された顧客DCの行位置を求める Range("F4").Value = Sheets("data").Cells(fRow, 2).Value Range("C5").Value = Sheets("data").Cells(fRow, 3).Value Range("C6").Value = Sheets("data").Cells(fRow, 4).Value Range("C7").Value = Sheets("data").Cells(fRow, 5).Value Range("F5").Value = Sheets("data").Cells(fRow, 6).Value End Sub '二つ目のプロシージャ(写真を表示させるためのコードです) Private Sub Worksheet_Change(ByVal Target As Range) Select Case Target.Address Case "$k$4" myLoadPicture "board_Image", Target.Text, Range("I5") Case "$K$17" myLoadPicture "map_Image", Target.Text, Range("I18") Case Else Exit Sub End Select End Sub

  • 検索後、行を抽出するVBAのProcedureで、

    いつも、参考にさせて頂いております。本当に有難く思っております。 下記のProcedureを使わせていただきたいのですが、検索シートのRange("A1:S1")に見出し行が、ありまして、貼り付け先シートにも見出し行をコピーして、その下の行から Do Loopでコピペしたいのですが、どうしても、記述の仕方がわかりません。MerlionXX様、及び、他にお解りになる方、どうか、お教えください。 1行目に行を挿入したり、Selection.Offset(1, 0).Select で1行さげて、そこへ見出し行をコピペしたりしましたが、貼り付け先シートの1行目のデータが、消えてしまうのです。そのデータの上に見出し行が、貼り付けられてしまうのです。    Selection.Insert Shift:=xlDown これもダメでした。 夜も眠れません。どなたか、下記のProcedure をどのように書き換えたら、貼り付け先シートに見出し行がコピペされ、その次の行から、 検索した行が、繰り返し貼り付けられるようになるのか、お教えください。 Sub test01() Dim ws1 As Worksheet, ws2 As Worksheet Dim rng As Range Dim myStr, ra, rr myStr = InputBox("検索する文字", " (´^∇^)σ 入力してください", "") If myStr = "" Then MsgBox "検索文字未指定", vbCritical, " Σ( ̄ロ ̄lll)" Exit Sub End If Set ws1 = Sheets("Sheet1") '検索 シート Set ws2 = Sheets("Sheet2") '貼付先シート With ws1.Columns("A") '部分一致で検索(A列) Set rng = .Find(What:=myStr, LookAt:=xlPart, After:=.Cells(.Cells.Count)) If rng Is Nothing Then 'なかったら MsgBox "ありません", vbCritical, myStr & "? ( ̄~ ̄;)う~ん  " Else 'あったら ra = rng.Address '最初に見つかったセルアドレス Do rr = rr + 1 'カウント rng.EntireRow.Copy Destination:=ws2.Cells(rr, 1) '行のコピペ Set rng = .FindNext(rng) '連続検索 Loop While rng.Address <> ra '繰り返し Set rng = Nothing End If End With MsgBox rr & "件をSheet2に抽出しました。", vbInformation, " ( ̄ー ̄)v" Set ws1 = Nothing Set ws2 = Nothing End Sub 宜しくお願い申し上げます。m(-_-)m

  • エクセルVBA 検索表示

    エクセルVBA 検索表示 例えばBooKの名前が”DATA”で Sheet1に下記のようなデーターがある場合   A  B  C  1 w 3  w 2 え 3  r 3 q 2  y 4 w 3  う 他のエクセルBook”検索”というエクセルを開き A1セルに”3”と表示させボタンをクリックすると 下記の表のように表示させたいです。   A   B  C 1 "3” 2 w  3  w 3 え  3  r 4 w  3  う "DATA"からB列の"3"を検索されデーターそのものが A2セル以降に表示させるにはどのようにすれば 良いですか? Private Const WBHName = "DATA.xls" Private Sub CommandButton1_Click() Dim WBH As Workbook Dim SH1 As Worksheet 'WBHのSheet1をセット Dim strMyBookPath As String Dim flag As Boolean 'ブックが空いているかの判定 Dim 最終行 As Long 'SH1の最終行を格納 Dim wb As Workbook Dim lng As Long strMyBookPath = ThisWorkbook.Path If Dir(strMyBookPath & "\" & WBHName) <> "" Then flag = False For Each wb In Workbooks If wb.Name = WBHName Then flag = True Exit For End If Next wb この後に続く記述を 教えて欲しいです。

  • Excel VBAのプロシージャについて

    こんにちは、VBAを作成しているのですが、分からない所があるので、詳しい方からのご教授をお願いします。 A                                 AF  _______________________________________________________________________  1|        1   2    3   4   5    ・・・  31   ←日付  2|  鈴木  11   15   35   8 25  3|  斉藤   45   52   25   21   50  4|  伊藤   25   45 75   36 16   ・1行目のB1セルからAFセルまで日付が入っています。 ・2行目のA2セルからA4セルまで名前が入っており、横方向にランダムな数字が入っています。 上記の表から、日付とランダムな数字を指定し検索する事でmsgboxで氏名を返せるように作っています。(例えば3日25で検索すると、msgboxで斉藤とでるようにする)。 自分なりに作ってみたのは、まずvbaを実行すると、A1行をautofilterで日付を検索し、activecell(検索結果の日付セル)の列からランダムな数字を再度autofilterで検索するというものですが、もっと記述について他に方法があるのではないかと疑問に思っていますので、このようなプログラムを作成する場合、慣れた方ならどのように記述するのでしょうか?よろしければ教えていただければと思いますのでよろしくお願いします。 ※実際は検索boxを作成していますが、AHセルに検索したい日付、AIセルに検索したいランダムな数字を入力するものとさせて頂きます。 ※EXCEL2000を使用しています。 ※中傷するような回答は遠慮させていただきます。 よろしくお願いします。

  • Excel VBA イベントプロシージャを2つ記述する(基本です)

    基本的な事なのですが、Excelのイベントプロシージャで2つプログラムを作るにはどうやって記述すればよいのでしょうか? 具体的には、worksheetのchangeイベントで、セルC5の値を変えた時と、セルG7の値を変えた時の2通りのマクロを作成したいのです。 Private Sub Worksheet_Change(ByVal Target As Range) C5を変えた時の処理 End Sub Private Sub Worksheet_Change(ByVal Target As Range) G7を変えた時の処理 End Sub このように書けばよいのでしょうか?そうするとTargetがかぶっておかしくなる気がします。。 お願いします。

  • VBAのプロシージャのことで

    TEST1のプロシージャ内に使用している readfileという変数の中にテストという文字列を代入し、 文字列が代入された状態で Callによって別のプロシージャを読みにいったとき TEST(変数)に入った文字列ごと持っていくには どの様に記述すればよいかどなたか教えていただけませんでしょうか・・・。。 ----------------------------------------------------------- Sub TEST () Dim readfile As String readfile = "テスト" Call TEST2 End Sub ----------------------------------------------------------- Sub TEST2() readfile ←テストという文字列をTESTプロシージャから持ってきたい End Sub ----------------------------------------------------------- 単純に書いてみたコードですが、この様なことは可能なのでしょうか? すいませんがいただけないでしょうか><;

  • VBA 特定もセルに入力で実行

    下記のコードを実行した際は問題なく実行されるのですが これを特定のセルに値が入力された際に動かそうとするとエラーになってしまいます。 Sub PaintTargetCharacter() Dim FoundCell As Range, FoundCell2 As Range Dim Addr As String Dim Addr2 As String Dim SearchArea As Range Dim SearchArea2 As Range Application.ScreenUpdating = False ActiveCell.Interior.ColorIndex = 0 '検索対象範囲 Set SearchArea = Worksheets("G番情報").Range("AE6:BG6") '検索実行 Set FoundCell = SearchArea.Find(What:=ActiveCell.Offset(0, -1), LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) '検索文字列を含むセルがない場合は終了 If FoundCell Is Nothing Then Exit Sub Set SearchArea2 = Range(FoundCell.Offset(1, 0), FoundCell.Offset(33, 0)) Set FoundCell2 = SearchArea2.Find(What:=ActiveCell, LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) If FoundCell2 Is Nothing Then Exit Sub FoundCell2.Copy Destination:=ActiveCell Application.ScreenUpdating = True End Sub 当然、特定のセルで値を入力後エンターキーを押すとアクティブセルは下に下がってしまうので Private Sub Worksheet_Change(ByVal Target As Excel.Range) Target.select Call PaintTargetCharacter End Sub としているのですが Set FoundCell = SearchArea.Find(What:=ActiveCell.Offset(0, -1), LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) の部分でエラーが起きてしまいます。 また停止してシートに戻るとセルのカーソル表示が消えてしまいます。 この現象はシートを閉じて再度開くと直りますが なにかエラーと関係しているのでしょうか? 初心者なのでおかしな部分が多々あると思います。 ご指摘などあれば宜しくお願いします。

  • VBAでプロシージャ間のデータを渡したい

    VBAでプロシージャ間のデータを渡したい main関数の中でget_Recordという関数を呼んでいます。この中でアクセスの テーブルからデータを取得して、「this_Hensuu」という変数に格納します。 やりたいことは、get_Recordで取得した変数をmain関数の中で利用したいです。 main()関数外で変数を宣言してグローバル変数とすれば解決するのは わかりますが、その他の方法でmain関数に値を渡すことは可能でしょうか? Sub main() Dim x = 10 Call get_Record(x) ... ... end sub Sub get_Record(Byref x As Integer) Dim rs As Dao.recordset Dim this_Hensuu As String Dim this_Hensuu2 As String get_SQL As String get_SQL ="" get_SQL="Select * from TABLE1 where ID='" & x & "'" rs = Openrecordset(get_SQL,opendynaset) this_Hensuu = rs!名前 this_Hensuu = rs!名前2 end sub

専門家に質問してみよう