複数のエクセルファイルのB列からD列までを抽出して一つのファイルにしたいです。

同一フォルダ内にある、複数のエクセルファイルのB列からD列までを抽出して一つのファイルにしたいです。

どうしてもうまくコードが組めません。
マクロのコードを教えていただけますでしょうか。

プラス
もし可能であれば、複数のエクセルファイルを開く際、すべて同じパスワード(例えば1234)が要求されるのですが、そのパスワードも自動で入力してデータを拾えるようにしたいです。よろしくお願いいたします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2018/11/20 21:50

こんばんは！

なかなか回答が付かないようですが・・・

ご自身でコードを記載された経験はあると思いますが、重要な情報が抜けています。

①　開きたいファイルの拡張子は「xlsx」で良いのか？
②　ブック名は判ってもそのブックの、どのSheetのB～D列を抜き出すのか？
③　コピー元が判ってもコード記載ブック（This Workbook）のどのSheetに抽出するのか？
④　抽出先はどの列なのか？

等々、上記①～④があいまいなままではエラーの原因になります。
回答者が条件を限定するのは、話が逆なのですが、
そこを設定しないとコードそのものが書けませんので

コピー元のブックの「Sheet1」のB～D列最終行までとします。
尚、すべてのブック（Sheet）は同じレイアウトで1行目が項目行になっていて、
データは2行目以降にあるとします。

そして貼り付け先は「This Workbook」のSheet1の1行目項目は入力済みで
A～C列に順次上から貼り付けるものとします。

以上の前提条件でのコードです。
標準モジュールです。

Sub Sample1()
　Dim myPath As String, fN As String
　Dim lastRow As Long
　Dim wB As Workbook, wS As Worksheet
　　myPath = ThisWorkbook.Path & "\"
　　fN = Dir(myPath & "*xlsx")
　　　Application.ScreenUpdating = False
　　　　Do Until fN = ""
　　　　　Workbooks.Open myPath & fN, Password:="1234"
　　　　　　Set wB = ActiveWorkbook
　　　　　　Set wS = wB.Worksheets("Sheet1")
　　　　　　　lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
　　　　　　　　Range(wS.Cells(2, "B"), wS.Cells(lastRow, "D")).Copy _
　　　　　　　　　ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　Application.DisplayAlerts = False
　　　　　　wB.Close
　　　　　Application.DisplayAlerts = True
　　　　　　fN = Dir()
　　　　Loop
　　　Application.ScreenUpdating = True
　　　　MsgBox "完了"
End Sub

※　この手の質問は何度も補足が付くことが多いパターンです。
お判りだと思いますが、VBAの場合1行・1列でも違った場合は意図しない動きになります。
そういう点を踏まえて、質問する際には細かい情報を書いた方が回答が付きやすいと思います。m(_ _)m