エクセルVBAで他のエクセルBookにデータを検索表示する方法
- エクセルVBAを使って他のエクセルBookにデータを検索表示する方法について教えてください。
- 例えば、名前が「DATA」のBookにあるデータの中から特定の値を検索し、他のBookでそのデータを表示させたいです。具体的な手順やコードなどを教えてください。
- また、検索結果を表示するためにどのようなVBAコードを使えば良いかも教えていただきたいです。
- ベストアンサー
エクセルVBA 検索表示
エクセルVBA 検索表示 例えばBooKの名前が”DATA”で Sheet1に下記のようなデーターがある場合 A B C １ ｗ ３ ｗ ２ え ３ ｒ ３ ｑ ２ ｙ ４ ｗ ３ う 他のエクセルBook”検索”というエクセルを開き A1セルに”３”と表示させボタンをクリックすると 下記の表のように表示させたいです。 A B C １ "3” ２ ｗ ３ ｗ ３ え ３ ｒ ４ ｗ ３ う "DATA"からB列の"３"を検索されデーターそのものが 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 この後に続く記述を 教えて欲しいです。
- pop2003
- お礼率60% (189/311)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （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
- ＥＸＣＥＬマクロ シートのありなし
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
- ベストアンサー
- その他MS Office製品
- エクセルVBAで読み取りパスワード回避
エクセル2010です。 以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。 しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。 読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB" などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。 そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。 （BOOK作成者にあとからパスワードを聞くため） しかし、残念ながらどのように書けばいいのか思いつきません。 ご指導いただければ幸いです。 Sub TEST001() Dim wb(1) As Workbook Dim ws(1) As Worksheet Dim myFdr As String, fn As String Dim i As Long With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定 If .Show = True Then myFdr = .SelectedItems(1) Else Exit Sub End If End With Application.ScreenUpdating = False '画面更新を一時停止 Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。 Set ws(0) = wb(0).Sheets(1) 'wb(0)の１枚目のシートをws(0)とする。 fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索 Do Until fn = Empty '全て検索 Application.EnableEvents = False Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。 Set ws(1) = wb(1).Worksheets(1) i = i + 1 ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記 ws(0).Cells(i, "B").Value = wb(1).Name ws(0).Cells(i, "C").Value = ws(1).Name wb(1).Close (False) '保存せず閉じる Application.EnableEvents = True fn = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新停止を解除 MsgBox i & "個取得" End Sub
- ベストアンサー
- Excel（エクセル）
- エクセル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 リストについて
エクセル VBA リストについて ComboBox3が例えばAなら ComboBox5にリストを入れたい 同じBookにSheet”masuta"がありそこに U1 V1 W1 X1 A B C D U列の下には”A"があり、Aの項目を入れ込んでいます。 ComboBox３が”A”と表示させた場合 ComboBox５はU列のU３以降の項目が入るようにしたいのですが 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
- ベストアンサー
- その他MS Office製品
- エクセルVBAでブックを開くと処理が終わってしまう
VBA初心者なのですが、VBAでエクセルブックを開くとVBAの処理が終わってしまいます。理由がわからないのでアドバイスをお願いします。なお、止まってしまう箇所にコメントを入れプログラムを下記しました。また、4000字以上質問できないためプログラムの途中までしか書かれていません。そのため、余分な宣言が多数ありますが無視してください。よろしくお願いいたします。 Option Base 1 Sub 健康診断の郵送() Dim kyoNum() As String Dim b_name As String Dim a_name() As Variant Dim b_address As String Dim a_address() As Variant Dim mailNum() As Variant Dim place() As String Dim banchi() As String Dim ken() As String Dim Adr As String Dim AdrLen As Integer Dim i, j, k, cnt, l, m As Integer Dim ChrCode As Integer Dim cell As Range Dim Book1 As String Dim wb As Workbook Dim Book1_Path As String Dim flag As Boolean 'セルのクリア ThisWorkbook.ActiveSheet.Cells.ClearComments 'セルのプロパティを設定をする With ThisWorkbook.ActiveSheet.Columns("A:B") .ShrinkToFit = True .NumberFormatLocal = "@" .ColumnWidth = 45 End With 'カレントディレクトリのチェンジ(Windows2000以降) CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path '簡易名称Book1にする Book1 = "Book1.xlsx" 'パスを取得する Book1_Path = ThisWorkbook.Path & "\" & Book1 If Dir(Book1_Path) = "" Then MsgBox "Book1.xlsxファイルが存在しません。", vbExclamation End If '同名ブックのチェック For Each wb In Workbooks If wb.Name = Book1 Then MsgBox "健康診断の郵送.xlsmはBook1を開こうとしています" _ & vbCrLf & "Book1を閉じて再実行してください", vbExclamation Exit Sub End If Next wb Application.ScreenUpdating = False '画面の更新を止める Workbooks.Open Book1_Path '＊＊＊＊＊←ここで処理が終わってしまう＊＊＊＊＊ 'ブック名を指定して非表示 Application.Windows("Book1.xlsx").Visible = False '後方検索でBook1.xlsxの入力済みセルの行数と列数を取得 With Workbooks("Book1.xlsx").ActiveSheet.UsedRange Book1_MaxRow = .Find("*", , xlValues, , xlByRows, xlPrevious).Row - 2 'データ入力済み行数取得 End With Application.ScreenUpdating = True Workbooks("Book1.xlsx").Activate j = 1 ReDim kyoNum(Book1_MaxRow) ReDim a_name(Book1_MaxRow) ReDim a_address(Book1_MaxRow) ReDim mailNum(Book1_MaxRow) ReDim ken(Book1_MaxRow) ReDim place(Book1_MaxRow) ReDim banchi(Book1_MaxRow)
- 締切済み
- Visual Basic
- エクセルVBA 重複を表示したい
エクセルVBA 重複を表示したい Ａ列で重複すると警告するコードを以下のように作成しました。 これを修正してＡ列で重複して、なおかつＢ列でも重複した場合警告するコードにしたいのです。 添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。 ご教授よろしくお願いします。 Sub test() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String For Each myRange In Range("A2:A10") If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub
- ベストアンサー
- その他MS Office製品
- エクセルＶＢＡ 重複を表示したい2
エクセルＶＢＡ 重複を表示したい2 以下ではたいへんお世話になりありがとうございました。 http://okwave.jp/qa/q5849885.html 上記に関連する質問をさせていただきます。 下記に提示したコードを修正して、以下のようなコードに変えたいと考えています。 「Ｂ列で重複したデータがあれば、そのすべてを左隣のデータと一緒に表示したい」 添付した図だと、 1小沢一郎 7〃 8〃 4鈴木一郎 6〃 以上のような感じです。 アドバイスよろしくお願いします。 Sub TEST() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String m_Rows = Range("b" & Rows.Count).End(xlUp).Row For Each myRange In Range("b2:b" & m_Rows) If WorksheetFunction.CountIf(Range("b2:b4000"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange.Offset(0, -1).Value & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub
- ベストアンサー
- その他MS Office製品
- エクセルVBA ブック間のコピー
選択したテキストファイルをエクセルで開いたコピーし、 もう一つ開いたエクセルファイルにペーストするというマクロをVBAで 作成していますが、つまずいてしまいました。 ----------------------------------- Dim wb1 As String Dim wb2 As String Sub Opentxt() wb1 = Application.GetOpenFilename("テキストファイル,*.txt") If wb1 <> "False" Then Workbooks.OpenText Filename:=wb1, DataType:=xlDelimited, comma:=True End If End Sub Sub Copy() Dim LastRow As Long wb2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls?") If wb2 <> "False" Then Workbooks.Open wb2 LastRow = wb2.Sheets("一覧表").Range("A" & Rows.Count). End(xlUp).Row wb2.Sheets("一覧表").Range("A5:A" & lastRow).Copy _ wb1.Sheets("Sheet1).Range("B33") End If End Sub ----------------------------------- Opentxtの方は問題ないですが、Copyの方を実行すると wb1とwb2で引っかかって「コンパイルエラー/ 修飾子が不正です」と 表示されて、エラーになってしまいます。 この場合変数の型などがおかしいのでしょうか？ excel2007を使用しています。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- エクセルVBAでBOOKを開く際の処理
エクセルVBAでBOOKを開く際の処理 エクセル2000です。 VBAで特定のフォルダー内のBOOKを開き、１枚目のシートSheets(1)のデータを読み込んで別BOOK（マクロを記載したBOOK）にコピペしたら保存せず閉じるコードを下記のように書きました。（かなり簡略化しましたが） これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても１枚目のシートのデータを読み込み後、閉じられてしまいます。 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
- ベストアンサー
- その他MS Office製品
- エクセルVBAで別ブックの条件検索
VBA初心者です。エクセルは2007です。 『データのあるブック（Book1,Book2,Book3）』と、『検索条件シート+出力先シートをもつブック』の４つのブックがあります。 検索条件シートで、L22でブック、P22でシートを指定してN22に入力した数に対応するデータをVlookupで出力先シートのセルに抽出されるようにしたいのですが、※の部分で「エラー438 オブジェクトは、このプロパティまたはメソッドをサポートしていません」とでて実行できません。 データのあるブックは同じ形式でシートには表があります。 数 a b c d 1 A B C D 2 ○ × △ ■ 3 Z Y X W ・ ・ 検索条件がL22=3,P22=2,N22=2だとすると、Book3の２枚目のシートを検索し、 出力先シートのD1=○,J6=×,L23=△,J69=■となるようにしたいです。 本やインターネットで調べましたがわかりませんでした。 解決方法を教えていただきたいです。お願いします。 Sub 検索() Dim a, b, c, d As Range Dim 番号, ブック, シート As Integer With Workbooks("検索.xlsm").Sheets("検索条件") 数 = .Range("N22").Value ブック = .Range("L22").Value シート = .Range("P22").Value End With Dim wb As Workbook Dim sh As Worksheet Dim set範囲 As Variant With Workbooks("検索条件.xlsm").Sheets("出力先") Set a = .Range("D1") Set b = .Range("J6") Set c = .Range("L23") Set d = .Range("J69") End With Select Case ブック Case 1 Set wb = Workbooks("Book1.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2） Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case 2 Set wb = Workbooks("Book2.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2) Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case 3 Set wb = Workbooks("Book3.xlsm") wb.Activate Select Case シート Case 1 Set sh = Worksheets(1) Case 2 Set sh = Worksheets(2) Case Else MsgBox "・・・・・", vbExclamation, "nothing" End Select Case Else MsgBox "nothing", vbExclamation, "nothing" End Select ※Set set範囲 = wb.sh.Range("A4:E42") ←エラー438 a = Application.WorksheetFunction.VLookup(数, set範囲, 2, False) b = Application.WorksheetFunction.VLookup(数, set範囲, 3, False) c = Application.WorksheetFunction.VLookup(数, set範囲, 4, False) d = Application.WorksheetFunction.VLookup(数, set範囲, 5, False) End Sub
- ベストアンサー
- その他MS Office製品
お礼
早速のお返事ありがとうございます！ ものすごく参考になりました。