複数のシートをまとめるとシートの順番がバラバラに。

質問

教えてください。初心者です。

1つ目。

http://okwave.jp/qa/q4225063.html
を参考にさせていただき、複数のブック内のシートを別の1つのブックのSheet1にまとめて書き出しました。

実際は「振替伝票1月」「振替伝票2月」・・・・「振替伝票12月」と12個のブック内に
「現金」「備品」「雑費」などの共通のシートがあります。

12個のブックの「現金」をSheet1に書き出しをしたのですが、上から「振替伝票8月」の「現金」、「振替伝票5月」の「現金」・・・と順番がバラバラに書き出されます。
「振替伝票1月」「振替伝票2月」・・・・「振替伝票12月」と12個を順番に書き出すにはどうしたらよいでしょうか？
色々調べましたがわかりません。
「Dir関数が返すファイルの順番」の説明のサイトを見つけたのですが、さっぱりわかりませんでした。

Sub Sample1()
Dim buf As String, i As Long
Dim j
buf = Dir(Sheets("Sheet1").Range("A1").Value & "\*.xls")
Do While buf <> ""
Workbooks.Open Worksheets("Sheet1").Range("A1").Value & "\" & buf
Sheets("現金").Range("A1:J1000").Copy
ThisWorkbook.Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False
buf = Dir()
Loop
End Sub

2つ目。
「現金」だけでなく「備品」「雑費」なども「現金」と同じブックの「Sheet2」「Sheet3」に書き出したいのですが、いろいろ調べてみるのですがわかりません。

ご教授の程、宜しくお願いいたします。

回答No.5

kmetu · ベストアンサー

> Workbooks.Open MyDir & "\" & buf
> の部分が実行エラーになります。

> BOOK1のSheet1のA1セルに「C:\Users\***\Desktop\振替え」と入力してます。

階層が深いところだと

buf = "振替伝票" & MyFileCount & "月" & ".xls"
Workbooks.Open MyDir & "\" & buf

がダメみたいですね。
ちょっとファイルを開く回数が必要以上になっていたのでそれも修正して

Sub Sample1()
Dim MyDir As String, buf As String, MyFileCount As Integer, MySheetCount As Integer
Dim MyFileName As String

MyDir = Sheets("Sheet1").Range("A1").Value

For MyFileCount = 1 To 12

buf = "振替伝票" & MyFileCount & "月" & ".xls"
MyFileName = MyDir & "\" & buf
Workbooks.Open MyFileName

For MySheetCount = 1 To 3

Select Case MySheetCount
Case 1
Sheets("現金").Range("A1:J1000").Copy
Case 2
Sheets("備品").Range("A1:J1000").Copy
Case 3
Sheets("雑費").Range("A1:J1000").Copy
Case Else
End Select

ThisWorkbook.Activate
With Sheets("Sheet1" & MySheetCount)
'With Sheets(MySheetCount)
.Activate
.Range("A65536").End(xlUp).Offset(1, 0).Select
.Paste
.Range("A1").Select
End With
Workbooks(buf).Activate

Next MySheetCount

Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False

Next MyFileCount

End Sub

お礼

ご回答ありがとうございます。
お返事が遅くなり、申し訳ございません。
出来ました。感謝です！
最後までわかりやすい回答をしていただきましてありがとうございました。

回答No.6

kmetu

寝ぼけてきました。

With Sheets("Sheet1" & MySheetCount)

With Sheets("Sheet" & MySheetCount)

にしてください。

回答No.4

kmetu

たびたび追加ですみません

With Sheets("Sheet" & MySheetCount)
を
With Sheets(MySheetCount)

にした場合

MyDir = Sheets("Sheet1").Range("A1").Value

のところも

MyDir = Sheets(1).Range("A1").Value

もしくは

MyDir = Sheets("実際のシート名").Range("A1").Value

に変更してください。

回答No.3

kmetu

すみません　iとｊが違ってました　訂正です
紛らわしいのでiとjをやめました。

Sub Sample1()
Dim MyDir As String, buf As String, MyFileCount As Integer, MySheetCount As Integer

MyDir = Sheets("Sheet1").Range("A1").Value

For MyFileCount = 1 To 12
For MySheetCount = 1 To 3

buf = "振替伝票" & MyFileCount & "月" & ".xls"
Workbooks.Open MyDir & "\" & buf

Select Case MySheetCount
Case 1
Sheets("現金").Range("A1:J1000").Copy
Case 2
Sheets("備品").Range("A1:J1000").Copy
Case 3
Sheets("雑費").Range("A1:J1000").Copy
Case Else
End Select

ThisWorkbook.Activate
With Sheets("Sheet" & MySheetCount)
.Activate
.Range("A65536").End(xlUp).Offset(1, 0).Select
.Paste
.Range("A1").Select
End With

Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False

Next MySheetCount
Next MyFileCount

End Sub

もし、シートの左端のシートから順番にコピーされていけばいいのでしたら
(シート名がSheet1とかでなくどんな名前になっても左端から順番にコピーされます)

With Sheets("Sheet" & MySheetCount)
を
With Sheets(MySheetCount)
に変更してください。

補足

ご丁寧な回答ありがとうございます。

お返事が遅くなってすいません。

Workbooks.Open MyDir & "\" & buf
の部分が実行エラーになります。

書き込むブックはBOOK1という名前になってます。
BOOK1のSheet1のA1セルに「C:\Users\***\Desktop\振替え」と入力してます。
振替伝票1月～振替伝票12月のブックは「振替え」という名前のフォルダーに入れてDesktopに置いています。

このあたりが間違っているのでしょうか？
よろしくお願いいたします。

回答No.2

kmetu

追加補足です。

Dim MyDir As String, buf As String, i As Integer

ここに

j As Integer

を追加してください。忘れてました。

回答No.1

kmetu

Sub Sample1()
Dim MyDir As String, buf As String, i As Integer

MyDir = Sheets("Sheet1").Range("A1").Value

For i = 1 To 3
For j = 1 To 12

buf = "振替伝票" & j & "月" & ".xls"
Workbooks.Open MyDir & "\" & buf

Select Case i
Case 1
Sheets("現金").Range("A1:J1000").Copy
Case 2
Sheets("備品").Range("A1:J1000").Copy
Case 3
Sheets("雑費").Range("A1:J1000").Copy
Case Else
End Select

ThisWorkbook.Activate
With Sheets("Sheet" & i)
.Activate
.Range("A65536").End(xlUp).Offset(1, 0).Select
.Paste
.Range("A1").Select
End With

Workbooks(buf).Activate
Application.CutCopyMode = False
Workbooks(buf).Close SaveChanges:=False

Next j
Next i

End Sub

こんな感じでいかがでしょう。