• ベストアンサー
  • すぐに回答を!

エクセル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 この後に続く記述を 教えて欲しいです。

共感・応援の気持ちを伝えよう!

  • 回答数1
  • 閲覧数173
  • ありがとう数1

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

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

workbookを開いた状態で Sub test() Dim WB1 As Workbook Dim WB2 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim i As Long Set WB1 = Workbooks("DATA.xls") Set WS1 = WB1.Worksheets("Sheet1") Set WB2 = Workbooks("検索.xls") Set WS2 = WB2.Worksheets("Sheet1") For i = 1 To WB1.WS1.Cells(Rows.Count, 1).End(xlUp).Row If WB2.WS2.Range("A1").Value = WB1.WS1.Cells(i, 2).Value Then WB1.WS1.Cells(i, 1).Resize(, 3).Copy WB2.WS2.Cells(Rows.Count, 1).End(xlUp).Offset(1) End If Next End Sub 参考まで

共感・感謝の気持ちを伝えよう!

質問者からのお礼

早速のお返事ありがとうございます! ものすごく参考になりました。

関連するQ&A

  • VBAで別ブックを複数列検索し、隣のセルの値を取得

    book2(master)のセルA1、2、3・・・・の値でbook1(data)の任意の複数列(以下では3列目、8列目としています)を検索し、検索結果の右側のセルの値(以下の例の場合4列目と9列目)をbook2(master)の検索元セルの右側に書き込みたいのですが、実行すると実行時エラー1004アプリケーションまたはオブジェクトの定義エラーです。 と表示されてしまいます。回避方法について教えて頂けますでしょうか また、複数列の検索方法について適切な方法がありましたら教えて頂けますでしょうか 例) master A2”aa” 空欄 ←hoを取得 A3”bb” 空欄 ←3aを取得 A4”cc” 空欄 data(ランダムに配置されています) 1 2 3 4 5 6 7 8 9    ca de      d4 2f    c1 3a      bb 3a    aa ho      7e ee Sub kensaku() Dim book1 As Workbook Dim book2 As Workbook Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim rng As Range Dim r As Long Set book1 = Workbooks.Open("D:\Book1.xls") Set book2 = Workbooks.Open("D:\Book2.xls") Set sheet1 = book1.Sheets("data") Set sheet2 = book2.Sheets("master") r = 2 Do While sheet2.Range("A" & r).Value <> "" Set rng = sheet1.Range(Columns(3), Columns(8)).Find(sheet2.Range("A" & r).Value, LookAt:=xlWhole) If Not rng Is Nothing Then sheet2.Range("B" & r).Value = rng.Offset(0, 1).Value End If r = r + 1 Loop End Sub

  • エクセルVBAでBOOKを開く際の処理

    エクセルVBAでBOOKを開く際の処理 エクセル2000です。 VBAで特定のフォルダー内のBOOKを開き、1枚目のシートSheets(1)のデータを読み込んで別BOOK(マクロを記載したBOOK)にコピペしたら保存せず閉じるコードを下記のように書きました。(かなり簡略化しましたが) これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても1枚目のシートのデータを読み込み後、閉じられてしまいます。 BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか? Sub TEST01()   Dim mb As Workbook, wb As Workbook   Dim myfd As String, fnme As String, ans As Byte, i As Long      ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")   If ans = vbNo Then     MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"     Exit Sub   End If      Set mb = ThisWorkbook   myfd = mb.Path   fnme = Dir(myfd & "\*.xls")      Do Until fnme = Empty     If fnme <> mb.Name Then       Set wb = Workbooks.Open(myfd & "\" & fnme)       i = i + 1       mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")       wb.Close (False) '保存せずに閉じる     End If     fnme = Dir   Loop        Set mb = Nothing   Set wb = Nothing   MsgBox i End Sub

  • もしも新規Excelファイルを開いてる場合は閉じる

    Excel2003です・ ユーザーが新規Excelファイル(book1)かテスト用ファイルを開いている場合は閉じる処理を考えております。 Option Explicit Dim ws As Workbook, flag As Boolean Private Sub Workbook_Open() For Each ws In Workbooks If ws.Name = "Book1" Then flag = True Next ws If flag = True Then Workbooks("Book1.xls").Close   Else   End IF For Each ws In Workbooks If ws.Name = "テスト用.xls" Then flag = True Next ws If flag = True Then Workbooks("テスト用.xls").Close   Else   End IF End Sub このコードだとBook1を開いているのに、Trueで拾ってくれません。 ws.Name = "Book1.xls"にしても同じです。 どこかおかしい部分があるのでしょうか?

  • VBA Excel処理の追加を2点教えてください

    Office2003(SP3) 以下は、昔、教えてもらったExcel VBAスクリプトで、よく使わせて もらってます。「C:\mybooks\」にあるxlsファイル(a001.xls、a002.xls、 a003.xls・・・・)を片っ端から開き、 1つのBookに束ねる動作をします。 これだけでも大変便利なのですが、もう少し改善いたしたく。 (1) 束ねられたBookのSheet名が、Sheet1、Sheet1 (2)、Sheet1 (3)、 Sheet1 (4)・・・ になってしまいます。そこで、ファイル名から拡張子を落 とした文字列をSheet名にセットする記述をご教示下さい。 (2) a001.xls、a002.xls、a003.xls・・・は、それぞれSheet1、Sheet2、 Sheet3を含みます。Sheet1だけが抜き取られてSheet2、Sheet3が残された大量 の残骸Bookが開きっぱなしになります。これら、保存せずに閉じる記述を追加 したいのですが。 よろしくお願い致します。 Sub OpenFiles() Dim i As Integer Dim wb As Workbook Dim fname Dim dirname As String ' i = 1 dirname = "C:\mybooks\" fname = Dir(dirname + "*.htm") If fname <> "" Then Do While fname <> "" If fname <> "." And fname <> ".." Then If i = 1 Then ' 最初のファイルを開く Workbooks.OpenText FileName:=dirname + fname Set wb = ActiveWorkbook ' 最初のファイルを新規ブックに複製して閉じる。 ActiveSheet.Copy wb.Close Set wb = ActiveWorkbook Else ' 2番目以降のファイルは複製した最初のファイルに追加 Workbooks.OpenText FileName:=dirname + fname ActiveSheet.Move After:=wb.Worksheets(wb.Worksheets.Count) End If i = i + 1 End If fname = Dir Loop Else MsgBox "検索条件を満たすファイルはありません。" End If Set wb = Nothing End Sub

  • エクセルVBAについて

    前回質問させていただきました件の追加機能になります。以前質問させていただきましたマクロが下記のものです。 Sub TESTa() Dim A As Long Dim B As Long Dim C As Long Dim D As Long Dim E As Long Dim F As Long '表の行数を調べる A = Worksheets("sheet1").Range("C65536").End(xlUp).Row - 1 For C = 1 To A For B = 4 To 7 'Sheet1のデータをSheet2に複写する Worksheets("Sheet2").Cells(B - 3 + D, 15) = Worksheets("Sheet1").Cells(C + 1, 1) Worksheets("Sheet2").Cells(B - 3 + D, 6) = Worksheets("Sheet1").Cells(C + 1, B) Worksheets("Sheet2").Cells(B - 3 + D, 14) = Worksheets("Sheet1").Cells(C + 1, 3) Worksheets("Sheet2").Cells(B - 3 + D, 10) = Worksheets("Sheet1").Cells(1, B) Worksheets("Sheet2").Cells(B - 3 + D, 13) = Worksheets("Sheet1").Cells(C + 1, 2) Next D = C * 4 Next 'Sheet2の表の行数を調べる Sheets("Sheet2").Select E = Worksheets("sheet2").Range("F65536").End(xlUp).Row '0欄の確認 For F = E To 1 Step -1 If Worksheets("Sheet2").Cells(F, 6) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Next End Sub カウントするとデータ個数がSheet1で約120件になりSheet2においては、4倍になりますので約480件になります。 そこで Sheet1において12件ごとに、Sheet2,3,4...としたいのです。 Sh1 NO.1~12がSheet2 Sh1 NO.13~24がSheet3 ... 10枚のシートにしたいのですが、このマクロにどのような命令を加えればよろしいでしょうか? お手数ですがよろしくお願いいたします。

  • VBA 条件検索について

    VBAの検索について質問です。 以下のようなものを作ろうと思います。 sheet1とsheet2がありsheet1のA、Bの数値をsheet2の同じA,Bの数値の値の行を検索して, その同じ値の行のsheet1のCの数値の値からsheet2のCの数値を引いた値をsheet3のC列に返すプログラムを作ろうと思います。空白などで同じ値がない場合はsheet3に空欄を返そうと思います。 以下に例をプログラムの実行例を示します。 sheet1 ■ A 列 B 列 C列 1: 7 | 1 | 3 2: 5 | 8 | 2 3: 2 | 3 | 1 4: 9 | 6 | 4 sheet2 ■ A 列 B列 C列 1: 2 | 3 | 4 2: 9 | 6 | 2 3: 7 | 1 | 5 4: 5|   | 3 sheet3 ■ A列 B列 C列 1: 7| 1 | -2 2: 3: 2| 3 | -3 4: 9 | 6 | 2 自分で以下のプログラムを作成してみたのですが空欄が検索できなかったりしてなかなかできません。 どなたか、教えてください。お願いします。 Sub test() Dim sh1 As Object, sh2 As Object, sh3 As Object Dim d1 As String, d2 As String, a As Long Set sh1 =Sheets(“Sheet1”) Set sh2 =Sheets(“Sheet2”) Set sh3 =Sheets(“Sheet3”) For a = 1 To 3000 Step 1 d1 = sh1.Cells(a,1) & sh1.Cells(a,2) d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Do while d2 <>”” If d1 = d2 Then Sh3.Cells(a,1) = sh1.Cells(a,1) Sh3.Cells(a,2) = sh1.Cells(a,2) Sh3.Cells(a,3) = sh1.Cells(a,3) Exit Do End If a= a+1 d2 = sh2.Cells(a,1) & sh2.Cells(a,2) Loop Next End Sub

  • EXCELマクロ シートのありなし

    EXCELのマクロでシートの存在を返す関数を作っています。 一応動くのですが、ブックをいちいちアクティブにしているのが 気に入りません。スマートな手法を教えて頂けませんか。 よろしくお願いします。 例)  A.xls、B.xls、C.xls、D.xlsのように複数のブックが開かれています。  マクロは、マクロ.xlsというファイルに記述しているとします。  例えば、A.xlsというファイルにsheet4という名前のシートが存在するか調べたい。 Function isExistingSheetName2(Bookname As String, sheetname As String) As Boolean Dim wb As Workbook Dim ws As Worksheet Dim flag As Boolean Dim wbown As Workbook Dim wsown As Worksheet '現在を記憶 Set wbown = ThisWorkbook Set wsown = ActiveSheet '判定 Set wb = Workbooks(Bookname) wb.Activate                  ’←特に気に食わない   For Each ws In Worksheets If ws.Name = sheetname Then flag = True Next ws '元に戻る wbown.Activate                ’←気に食わない    wsown.Select                 ’←若干気に食わない   '戻り値 If flag = True Then isExistingSheetName2 = True Else isExistingSheetName2 = False End If End Function ’excel 2002 SP3 ’windowsXP Pro SP3

  • エクセル VBA リストについて

    エクセル VBA リストについて ComboBox3が例えばAなら ComboBox5にリストを入れたい 同じBookにSheet”masuta"がありそこに U1 V1 W1 X1 A  B C  D U列の下には”A"があり、Aの項目を入れ込んでいます。 ComboBox3が”A”と表示させた場合 ComboBox5はU列のU3以降の項目が入るようにしたいのですが Set wbMyBook = Workbooks(strMyBookName)エラー表示され 型の一致がしないと表示されます! このBookの格納はしているつもりなのですが上手く 回避できません教えて下さい。 それと下の記述をどのように変化させれば良いか アドバイスお願いします。 Private Const WBHName = "k2.xls" Private Const SH1Name = "Sheet1" Private Const wsListName = "masuta" Dim lngYcnt_List As Long '使用行を格納 Dim wbMyBook As Workbook 'このブックをセット Dim wsList As Worksheet 'リストシートをセット Dim strMyBookName As String 'このブックの名前を格納 Private Sub ComboBox3_Change() Dim lng As Long '使用するブックとシートをセット Set wbMyBook = Workbooks(strMyBookName) Set wsList = wbMyBook.Worksheets(wsListName) 'リストシートの使用行を格納 lngYcnt_List = wsList.Range("masuta!U1:X1").CurrentRegion.Rows.Count 'コンボボックスComboBox1のクリア・フラグをfalseにする。 ComboBox5.Clear flag = False '同じ数字のもののコンボボックスComboBox1に追加。 For lng = 1 To lngYcnt_List If ComboBox3.Value = wsList.Cells(lng, 21) Then 'ComboBox1,TextBox8,呼吸具体策に表示する。 ComboBox5.AddItem wsList.Cells(lng, 21) End If If ComboBox3.Value = wsList.Cells(lng, 22) Then ComboBox5.AddItem wsList.Cells(lng, 22) End If If ComboBox3.Value = wsList.Cells(lng, 23) Then ComboBox5.AddItem wsList.Cells(lng, 23) '処理を抜けるExit For flag = True End If Next lng End Sub

  • エクセルVBAでBOOKに読み取りパスワード設定

    エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01()   Dim myfdr As String, fname As String   Dim mb As Workbook, wb As Workbook   Dim n As Long   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定      If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。"       Exit Sub     End If   End With   Set mb = ThisWorkbook 'このコピー先ブックをmbとする。   fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索   n = 2   Do Until fname = Empty '全て検索     Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。     With mb.Sheets("Sheet1") '転記       .Cells(n, "B").Value = wb.FullName       .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value     End With     n = n + 1 'カウント     Application.DisplayAlerts = False     wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"     wb.Close     Application.DisplayAlerts = True     fname = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   MsgBox n - 2 & "件処理しましました。" End Sub

  • EXCEL VBA 文字列検索とコピー

    以前にも同じ質問をさせて頂いたのですが、どうも上手くいかないので今一度お願い致します! 名簿を作成していて、現在下記のようなシートになっています。 [ Sheet1 ] A   B   C   D   E   F   G   H 日付 ○  ○  ○  ○  名前 電話 メール このF列の名前を検索して、検索文字に該当する全てのセルの行ごと(出きればA1:H2の範囲)コピーして、Sheet2に貼り付けたいです。 現在のコードは、以下のようになってます。 宜しくお願いします!! Sub 検索1() Dim myFind As Variant Dim myfRow As Long, c As Range Dim CopySh As Worksheet Dim i As Long Dim num As Integer Set CopySh = Worksheets("Sheet2") 'コピー先のセルの最初の行 i = 1 '================================== myFind = Application.InputBox("検索文字をカナで入力してください", Type:=2) If VarType(myFind) = vbBoolean Or myFind = "" Then Exit Sub With Worksheets("Sheet1").Cells(4.4) Set c = .Find(myFind, , xlValues, xlWhole) If Not c Is Nothing Then myfRow = c.Row Do c.Copy CopySh.Cells(i, 1) 'コピー Set c = .FindNext(c) i = i + 1 Loop Until c Is Nothing Or myfRow = c.Row End If End With Beep '終了の合図