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

エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

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

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

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

  • ベストアンサー
  • 回答No.1
  • bonaron
  • ベストアンサー率64% (482/745)

Set ws = wb.Worksheets(1) です。

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

質問者からのお礼

目からうろこです。こんな近くに答えがあるなんて・・・。 ありがとうございました。

関連するQ&A

  • エクセルVBAでつまずいています

    教えてください。以前別のブックから、抽出条件を指定して、 項目を追加して、ある条件を検査して、それによって追加した項目の列 に対応する値を書き込むというコードを教えていただきました。 質問は、今現在、 With .Range("AH2").Resize(r - 1, 1) .FormulaR1C1 = _ "=IF(RC[-25]=""AAA"",""aaa""," & _ "IF(RC[-25]=""BBB"",""bbb""," & _ "IF(RC[-25]=""CCC"",""ccc""," & _ "IF(RC[-25]=""DDD"",""ddd"",""xxx"") の部分で、関数を設定していますが、AIの列にも同じように関数 (VLOOKUP)を設定したいのですが、Resize(r - 1, 1)の意味するところが しっかり理解していないためできません。 A1形式ですが、例えば、 参照先がD2、A2:J100として =VLOOKUP(D2,A2:J100,5,FASE) =VLOOKUP(D2,A2:J100,6,FASE) =VLOOKUP(D2,A2:J100,7,FASE) という条件を追加したいのですが、わかりませんでした。 どのようにしたらいいでしょうか。よろしくお願いします。 Sub test() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("条件入力") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("元データ") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With .Range("AH1").Value = "追加項目A" .Range("AI1").Value = "追加項目B" .Range("AJ1").Value = "追加項目C" .Range("AK1").Value = "追加項目D" With .Range("AH2").Resize(r - 1, 1) .FormulaR1C1 = _ "=IF(RC[-25]=""AAA"",""aaa""," & _ "IF(RC[-25]=""BBB"",""bbb""," & _ "IF(RC[-25]=""CCC"",""ccc""," & _ "IF(RC[-25]=""DDD"",""ddd"",""xxx"") End With End With nb.SaveAs _ Filename:=ms.Parent.Path & "\" & _ Replace(wb.Name, ".xls", "") & "更新データ.xls" wb.Close False nb.Close Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing End With End Sub

  • エクセルVBAで別ブックの条件検索

    VBA初心者です。エクセルは2007です。 『データのあるブック(Book1,Book2,Book3)』と、『検索条件シート+出力先シートをもつブック』の4つのブックがあります。 検索条件シートで、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の2枚目のシートを検索し、 出力先シートの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

  • 【VBA】複数のブックを1つのシートにまとめる

    あるフォルダ内に複数のブックが入っており、新しいブックに1シートでまとめようとしております。 フィルターを使用すればよいのかもしれませんが、マクロを使用したいです。 (1)全て同じフォーマットである (2)全てA17から数値が入力されているので、16行目まではフォーマットを残し、A17行目以降K列までをコピーして結合したい Sub 結合() '結合したいファイルがあるフォルダの場所 cドライブなら "C:\test\" Const Fol As String = "C:\test\" Dim Fn Dim NewFile As Workbook Dim Wb As Workbook Dim Ws1 As Worksheet Dim R As Range Set NewFile = Workbooks.Add Set Ws1 = NewFile.Worksheets(1) Set R = Ws1.Range("A17") Fn = Dir(Fol, vbNormal) Do Until Fn = "" Set Wb = Workbooks.Open(Fol & Fn) 'ワークシート1をコピーする場合は Wb.Worksheets(1) Set Ws1 = Wb.Worksheets(1) 'タイトル行を設定 If ck = False Then For cnt = 1 To 4 Wb.Worksheets(cnt).Range("A1:J16").Copy Destination:=NewFile.Worksheets(cnt).Range("A1") Next cnt ck = True End If For cnt = 1 To 4 Set Ws1 = NewFile.Worksheets(cnt) Set Ws2 = Wb.Worksheets(cnt) R = Ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1 With Ws2 End With Next 'A17行目からコピーして結合する(→本当はA17行目&#65374;K列までを反映したい) Ws2.Range("A17", Ws2.Cells(Rows.Count, 3).End(xlUp)).Resize(, 20).Copy R If R.Offset(1).Value = "" Then Set R = R.Offset(1) Else Set R = R.End(xlDown).Offset(1) End If Wb.Close 'Debug.Print Fn Fn = Dir Loop Set R = Nothing Set Ws1 = Nothing: Set Ws2 = Nothing Set Wb = Nothing: Set NewFile = Nothing End Sub マクロは触ったことない初心者でグーグル検索をしながら作ってみました。 一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。 どなたかおわかりになりますでしょうか・・・。

  • VBA マクロ シート 転記

    はじめまして。VBA初心者です。今シート1のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート2のB列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート2の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか?宜しくお願いします。

  • ブック内に特定名のシートがある場合

    はじめまして、こんにちは。 VBAを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub

  • エクセル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)の1枚目のシートを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

  • VBA 実行時エラーで、"プロパティまたはメソッド

    ・Sheet1(コード) Private Sub CommandButton1_Click() Call aaa End Sub ・Module1(コード) Sub aaa() Dim wb As Workbook Dim ws As Worksheet Workbooks.Open ("c:\test.xls") Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") wb.ws.Range("A2").Value = "CCC" End Sub wb.ws.Range("A2").Value = "CCC"の部分で 以下の実行エラーが出ます。 ------------------------------------------------------------------------ 実行時エラー'438': オブジェクトは、このプロパティまたはメソッドをサポートしていません。 ------------------------------------------------------------------------ Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") の部分で特にエラーも出ないので、オブジェクトの取得は成功していると 思うのですが、WorkSheetオブジェクトのwsからRangeメソッドを呼ぶことが できません。 動かない原因と対策を教えてください!!

  • エクセル 毎月分のデータを年間シートに移植するマクロ

    エクセル 毎月分のデータを年間シートに移植するマクロ いつもお世話になっております。 こちらで毎月のデータをコピーして、年間シートの最終行に貼り付けるマクロを 以下のとおり教えていただきました。 今、3シート分になっているのですが、これを1-1を1-4だけのマクロにする場合、 Set Ws(3) = Worksheets("2-1") Set Ws(4) = Worksheets("2-3") Set Ws(5) = Worksheets("3-1") Set Ws(6) = Worksheets("3-2") この↑部分を削るだけではだめなのでしょうか? 試してみたところ、オブジェクトの変数またはwithブロック変数が設定されていませんとの エラーが出てしまいました。 下記マクロを1-1→1-4だけにするマクロの修正を教えていただきたくお願いいたします。 シート 1-1 毎月決まった項目のデータが入ります。 ↓ 1-4 1-1の月データを一年分貼付 2-1 毎月決まった項目のデータが入ります。 ↓ 2-3 2-1の月データを一年分貼付 3-1 毎月決まった項目のデータが入ります。 ↓ 3-2 3-1の月データを一年分貼付 ******************************************************************************** Sub Harituke() Dim k As Integer Dim Rng As Range Dim Ws(6) As Worksheet Set Ws(1) = Worksheets("1-1") Set Ws(2) = Worksheets("1-4") Set Ws(3) = Worksheets("2-1") Set Ws(4) = Worksheets("2-3") Set Ws(5) = Worksheets("3-1") Set Ws(6) = Worksheets("3-2") For k = 1 To 5 Step 2   Set Rng = Ws(k).Cells(1, 1).CurrentRegion   Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count)   Rng.Copy Ws(k + 1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Next k For k = 1 To 6   Set Ws(k) = Nothing Next k Set Rng = Nothing End Sub

  • エクセルVBAでファイル作成

    エクセルVBAで、データをフィルタで抽出し、別なBOOKの指定シートに転記し、名前をつけて保存したいのです。一応、下記のコードでテストは成功しました。 しかし下記コードでは1回ごとにデータの転記先を開かなくてはなりません。 処理する件数が多いので、できればいちいち新たに開き直さなくともよい方法はないでしょうか? 最初から開いておいて、転記後名前をつけて保存すると、開いていたファイルが閉じてしまい、うまくいきません。 別BOOKでなく別シートに転記して、そのシートをMoveして別ファイル保存ならわかるのですが、今回はどうしても別BOOKに転記しなければなりません。 よろしくお願いします。 Option Explicit Sub データ分割転記()   Dim myPth As String, fname As String   Dim myRng As Range, myC As Range   Dim i As Long, x As Long   Dim wb(2) As Workbook   Dim ws As Worksheet   Dim t As Single   t = Timer   Set wb(0) = ThisWorkbook   myPth = wb(0).Path   With wb(0).Sheets("Key")     Set myRng = .Range("A2", .Range("A2").End(xlDown)) 'KeyData   End With      For Each myC In myRng     Application.EnableEvents = False     Set wb(1) = Workbooks.Open(Filename:=myPth & "\20150806TEST.xlsm")     Set ws = wb(1).Sheets("List")        With wb(0).Sheets("DATA")       .Range("A1:J1").AutoFilter Field:=4, Criteria1:=myC.Value       .Range("A2", .Range("A2").SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).Copy ws.Range("A9")       .ShowAllData     End With     With ws       x = .Cells(Rows.Count, "A").End(xlUp).Row       myC.Offset(, 2).Value = x '行数確認       .Range("A9").Value = 1       If x > 9 Then         .Range("A9").AutoFill Destination:=.Range("A9:A" & x), Type:=xlFillSeries '連番       End If     End With     wb(1).SaveAs Filename:=myPth & "\作成ファイル\" & myC.Value & ".xlsm"     wb(1).Close (False)     Application.EnableEvents = True     i = i + 1   Next   MsgBox i & "件を完了" _   & vbCrLf & Timer - t & " Sec." End Sub *Application.EnableEvents = False を使っているのば別BOOKが持つイベントマクロを作動させないためです。

  • エクセルVBAのオートフィルタについて

    いつもお世話になります。 エクセル2007でVBAでオートフィルタを操作したいのですが、 一部うまくいきません。 以下の様なコードを書いて 日付で絞り込みたいのですが、 何も抽出されません。 リストを見てみると、変数はちゃんと入っており OK ボタンを押すとその日付で抽出されます。 何故VBAでの操作では抽出されないのでしょうか。 ご存じの方がおられましたら、よろしくお願いします。 Sub test() Dim mydate As Variant Dim rng3 As Range Dim fmt As Variant Dim objList3 As ListObject Dim wb1 As Workbook Dim wb2 As Workbook Dim wb4 As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim sh3 As Worksheet Dim sh4 As Worksheet Dim sh7 As Worksheet '----------------------------------------------------------------------- Set wb1 = Workbooks("301.xlsm") Set wb2 = Workbooks("1.xls") Set wb4 = Workbooks("2.xls") Set sh1 = wb1.Worksheets("@") Set sh2 = wb1.Worksheets("@@") Set sh3 = wb2.Worksheets("@@@") Set sh4 = wb2.Worksheets("@@@@") Set sh7 = wb4.Worksheets("@@@@@") '---------------------------------------------------------- sh2.Range("A1:z63").ClearContents With sh7 Set objList3 = .ListObjects("リスト1") fmt = .Range("A2").NumberFormatLocal mydate = Format(mydate, fmt) objList3.Range.AutoFilter Field:=7, Criteria1:=mydate objList3.Range.AutoFilter Field:=5, Criteria1:="test" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A2") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=5, Criteria1:=">=190" Set rng3 = objList3.Range.SpecialCells(xlCellTypeVisible) rng3.Copy sh2.Range("A20") objList3.Range.AutoFilter Field:=5 objList3.Range.AutoFilter Field:=7 End With Application.CutCopyMode = False Set rng3 = Nothing Set fmt = Nothing Set objList3 = Nothing Set wb1 = Nothing Set wb2 = Nothing Set wb4 = Nothing Set sh1 = Nothing Set sh2 = Nothing Set sh3 = Nothing Set sh4 = Nothing Set sh7 = Nothing End Sub (一部省略しています)