すべてのファイルにデータを取得方法

質問

VBAで一覧作成を作っているですけど、ちょっと力不足のせいで、わからないところがあって、ぜひご教示ください。
フォルダにあるすべてのファイルを読み込んで、中の値を取得したいです。いろいろ方法を試して見たのですが、うまく行かないです。
こんな感じです。(一覧作成見たいもの)
ｘｌｓファイル１
　　A　　B　　　C　　　　　D
１　氏名　NO　オーダー名　　時間

に
指定されたフォルダ中のすべてファイル
A　　　B　　　　　C (一つのファイル)
1 氏名　 　山田　
2　No オーダー名　　時間
3　01 　　　A 1
4　02 　B 1
5　03 　B　 1

氏名　 　佐藤　 (二つのファイル)
No オーダー名　　時間
03 　C 1
04 　D 1
05　　 　E 1
・
・
・
の最後のファイルまでを
読み込んだら
ｘｌｓファイル１を
　A　　B　　　C　　　　　D
氏名　NO　オーダー名　　時間
山田　01 A 1
山田 02 B 2
佐藤 03 C 1
佐藤 04 D 1
佐藤　05　　　E 　　　　　1
・
・
・
こんな感じ

Dim BookName As String
Dim PathName As String
Dim WS1 As Worksheet
Dim WS2 As Worksheet

Dim no2_count As Long
’ｘｌｓファイル１
Set WS1 = Worksheets("個人一覧作成")
no2_count = WS1.Cells(Rows.count, 1).End(xlUp).Row
Dim i As Integer
For i = 2 To no2_count Step 1
PathName = "C:\test\"
BookName = Dir(PathName & "*.xls", vbNormal)
Do Until BookName = ""
Workbooks.Open PathName & BookName

Set WS2 = Worksheets(2)
　　’氏名の値を取得
WS1.Range("A" & i).Value = WS2.Cells("B,C", 2).Value
Workbooks(BookName).Close
　　　BookName = Dir()
Loop
Next i
初心者なので今の段階では氏名の値すら取得できないですけど、
簡単でも結構ですので、どなたは方法をご教示ください。

回答No.4

fujillin

まず、考えているものを単純化して基本的な部分を実現してみましょう。

例えば、『一つのファイル、ファイル名"×××"（←変数にしておくが値は固定）からデータを読んで、一覧のシートにコピーする。』
これだけでも、失礼ながら、少々手を焼きそうな気配です。

これができたら、次に、少し手を加えて複数のファイルへの対応とか、フォルダを指定したらその中のファイルデータを全部拾い出してくるとかする手順が、回り道に見えるかも知れませんが結果的に早道だと思います。

さて、ご提示のコードですが
2重のループで構成されていて、
For i = 2～
　　Do Until BookName = ""
　　　　処理
　　Loop
Next i
となっていますが、このままだと、「処理」の部分が内側のループで繰り返されている間iの値は一定です。ところが、その処理の中で
　WS1.Range("A" & i).Value =～
と、値を書き込んでいるけれど、同じセルに何度書き込んでも意味がないですね。
ループの構造が違っていると思いますけれど…??

さらに、外側のループの範囲を
no2_count = WS1.Cells(Rows.count, 1).End(xlUp).Row
For i = 2 To no2_count
として決めていますが、これだとWS1のA列のデータが入力されているセルに上書き記入するようになっていますが、そういう意図でしょうか？
また、このループの回数はシートの既記載行数で決まりますが、データ数はユーザが指定するファイルの数とその中のデータ数で決まるので、シートに記載済みのデータ数で決まるのではないように思えますが??

補足

ご教示いただきまして、ありがとうございました。

回答No.3

n-jun

＃２です。

＞ws1.Range("A1").Resize(,　3).Value　=　Split("氏名　NO　オーダー名　時間")
ここを
ws1.Range("A1").Resize(, 4).Value = Split("氏名 NO オーダー名 時間")
こちらに入れ替えて下さい。

ごめんなさい。

回答No.2

n-jun

＃１です。

ｘｌｓファイル１のシートに何もデータがない（１行目に）状態から実行した場合なら、

Sub　try()
　Dim　myDic　As　Object
　Dim　ws1　As　Worksheet
　Dim　ws2　As　Worksheet
　Dim　r　As　Range
　Dim　PathName　As　String,　BookName　As　String
　Dim　v　As　Variant,　vv　As　Variant,　i　As　Long

　Set　myDic　=　CreateObject("Scripting.Dictionary")
　Set　ws1　=　Worksheets("Sheet1")　'Worksheets("個人一覧作成")　？
　Set　r　=　ws1.Range("A2")
　ws1.Range("B:B").NumberFormatLocal　=　"@"
　ws1.Range("A1").Resize(,　3).Value　=　Split("氏名　NO　オーダー名　時間")

　Application.ScreenUpdating　=　False

　PathName　=　"D:\"　'"C:\test\"
　BookName　=　Dir(PathName　&　"*.xls",　vbNormal)

　Do　Until　BookName　=　""
　　　　Workbooks.Open　PathName　&　BookName
　　　　Set　ws2　=　Workbooks(BookName).Worksheets(1)　'Worksheets(2)　？

　　　　With　ws2
　　　　　　　　　v　=　.Range(.Range("A3"),　.Cells(Rows.Count,　1).End(xlUp)).Resize(,　3).Value
　　　　End　With

　　　　For　i　=　1　To　UBound(v,　1)
　　　　　　　　If　myDic.Exists(v(i,　2))　=　False　Then
　　　　　　　　　　　myDic(v(i,　2))　=　Array(ws2.Range("B1").Value,　v(i,　1),　v(i,　2),　Val(v(i,　3)))
　　　　　　　　Else
　　　　　　　　　　　vv　=　myDic.Item(v(i,　2))
　　　　　　　　　　　vv(3)　=　vv(3)　+　Val(v(i,　3))
　　　　　　　　　　　myDic(v(i,　2))　=　Array(vv(0),　vv(1),　vv(2),　vv(3))
　　　　　　　　End　If
　　　　Next
　　　　r.Resize(myDic.Count,　4).Value　=　Application.Transpose(Application.Transpose(myDic.Items))
　　　　Set　r　=　r.Offset(myDic.Count)
　　　　myDic.RemoveAll
　　　　Erase　v,　vv

　　　　Workbooks(BookName).Close
　　　　BookName　=　Dir()
　Loop
　Application.ScreenUpdating　=　True

　Set　myDic　=　Nothing
　Set　ws1　=　Nothing
　Set　ws2　=　Nothing
　Set　r　=　Nothing
End　Sub

こんな感じの事でしょうか。

補足

ちょっと知識が浅くて、理解できないところがあります。
コードまで丸教えて頂きまして、ありがとうございました。

回答No.1

n-jun

＞A　　　B　　　　　C (一つのファイル)
＞1 氏名　 　山田　
＞2　No オーダー名　　時間
＞3　01 　　　A 1
＞4　02 　B 1
＞5　03 　B　 1
これと

＞氏名　NO　オーダー名　　時間
＞山田　01 A 1
＞山田 02 B 2
これの関係でオーダー名：Ｂの時間：２とはどういう事でしょう？
その際のNOとの関係は？

と感じました。

補足

”NO　”　はオーダー番号でした、手抜きしてすみませんでした。

A　　　B　　　　　C (一つのファイル)
1 氏名　 　山田　
2　No オーダー名　　時間
3　01 　　　A 　　　　1
4　02 　　　B 　　　　1
5　02 　　　B　 　　　1
行番号5のところは修正しました。こんな感じです。
曖昧で申し訳ございません。