エクセルVBA フォルダ内のどんなシート名であっても読み込みたい
- フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付ける方法
- Set ws = wb.Worksheets("情報")という行で特定のシートを限定しているが、どのようにコードに変更すればD3のファイルのどんなシート名であっても読み込めるようになるか
- D3で指定するブックには必ず1つのシートしかないため、任意のシート名で読み込む必要がある場合は、シート名を指定する代わりにループを使って全てのシートを読み込む方法が必要
- ベストアンサー
エクセル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
- reprogress
- お礼率45% (40/87)
- オフィス系ソフト
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
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】複数のブックを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行目～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 マクロは触ったことない初心者でグーグル検索をしながら作ってみました。 一応実行するとエラーは出ないのですが、結合されたリストが飛び飛びで、理由がわかりません。 どなたかおわかりになりますでしょうか・・・。
- ベストアンサー
- Visual Basic
- エクセル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 （一部省略しています）
- ベストアンサー
- その他MS Office製品
- 複数のエクセルシートをまとめるマクロ
下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub
- ベストアンサー
- Excel（エクセル）
- VBAエクセルにて開いてないエクセルシートを開いてるシートに所得
お世話になります。 「同じフォルダー内にBOOKが2つ有ります。1つ（AK.xls）を立上げて もう1つの（EX.xls）を立上げずに、EX.xls内のSheet1をコピーして AK.xlsのシート（STEP1）に貼り付けようとしています。」 どうしてもエラーが出てしまいます。 何方か、分かる方教えて下さい。 また記述して戴ければもっと助かります。 エラーは”1004”EX.xlsが見つかりません。と出てしまいます。 Sub ST() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("STEP1").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select Set wsSrc = ActiveSheet Workbooks.Open "EX.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub デバックでは Workbooks.Open "EX.xls"この部分が黄色になります。 是非、回答を宜しくお願い致します。
- ベストアンサー
- オフィス系ソフト
- エクセル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製品
- エクセルのＶＢＡの記述について
ＶＢＡの記述についてなのですが、 Sub filter() Dim gyo As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Set ws1 = Worksheets("データ") Set ws2 = Worksheets("チーム") Application.ScreenUpdating = False ws2.Range("A4:BH30").Clear gyo = ws1.Range("A65536").End(xlUp).Row ws1.Activate With ws1.Range(Cells(4, 1), Cells(gyo, 6)) .AutoFilter Field:=1, Criteria1:="A" .SpecialCells(xlCellTypeVisible).Copy ws2.Range("A4") Selection.AutoFilter End With Application.ScreenUpdating = True End Sub ならプログラムははしるのですが、 １４行目を .SpecialCells(xlCellTypeVisible).Copy ws2.Range(Cells(4, 1)) だと 「実行時エラー １００４ Rangeメソッドは失敗しました Worksheet オブジェクト」 とでるのですが、出来ないのでしょうか？ Cells(4, 1)の１のところを変数にして変えていきたいのですが、よい方法はありますか。 よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- エクセル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が持つイベントマクロを作動させないためです。
- ベストアンサー
- Excel（エクセル）
- エクセル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（エクセル）
- ブック内に特定名のシートがある場合
はじめまして、こんにちは。 ＶＢＡを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 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
- ベストアンサー
- Visual Basic
お礼
目からうろこです。こんな近くに答えがあるなんて・・・。 ありがとうございました。