Excel VBA 複数のブックの複数シートから

Excel VBA 複数のブックの複数シートからデータをコピーするマクロを作成したのですが、
コピー部分が上手く作動せず、訳の解らないデータが貼り付いてしまいます。

ちゃんとファイルは読み込んでいます。
、
VBA超初心者なので、うまく動作しませんでした。
どこが悪いのか教えて頂けないでしょうか。

やりたいことは
・同一フォルダ内に複数のExcelファイルがある
・各ファイル内には複数のシートがあり、シート数はファイル毎にばらばら
・各シートの構造は全て同じ
・VBAを保存してあるExcel（貼り付け用.xls）も同じフォルダに置いて作業します
・JEまとめ.ファイルの原本シートをコピーして、シート名に日付を入れたシートに
・全シート下記のセルのコピー(値、縦横変換)を日付をいれた原本コピーのシートに
B1～3セル→A～C
B4～5セル→G～H
B6セル→J
J22～24→D～F
をシートの一番最初の行は見出しなので、その後上から順に値の貼付けをしたいのです。
エクセルは2003です。
宜しくお願いいたします。

Sub 集計コピー操作()

Dim 集 As Workbook, 開 As Workbook
Dim 原 As Worksheet, コピー As Worksheet
Dim パス As String, フォルダ As String
Dim 日付 As String
Dim 紙 As Integer
Dim 終 As Integer
Dim 数 As Long '書込み行

'日付取得
日付 = Format(Date, "yyyymmdd")
'新規シート追加
'シート名チェック
Set 集 = ThisWorkbook
For Each 原 In 集.Worksheets
If 原.Name = 日付 Then
原.Activate
Exit For
End If
Next 原

'シート作成
If 原 Is Nothing Then
'シート名が存在しない場合は作成
Sheets("原本").Copy Before:=Sheets(1)
Set 原 = ActiveSheet
原.Name = 日付
Else
End If

'Application.ScreenUpdating = False '画面ちらつき防止

'ファイル名設定
Set 集 = ThisWorkbook 'このbookをまとめとする。
パス = ThisWorkbook.Path 'このbookのパスを取得
フォルダ = Dir(パス & "\*.xls") 'フォルダ内のExcelブックを検索

Do Until フォルダ = Empty '全て検索

If フォルダ <> 集.Name Then 'book名がこのbookの名前でなければ

'コピーブックの設定
Set 開 = Workbooks.Open(パス & "\" & フォルダ) '開ファイルとする。

紙 = Worksheets.Count 'シートカウント
For 終 = 1 To 紙
数 = 数 + 1

'シートループ処理
For Each コピー In 開.Worksheets

With WorksheetFunction
原.Cells(数, "A").Value = コピー.Range("B1").Value
原.Cells(数, "B").Value = コピー.Range("B2").Value
原.Cells(数, "C").Value = コピー.Range("B3").Value
原.Cells(数, "G").Value = コピー.Range("B4").Value
原.Cells(数, "H").Value = コピー.Range("B5").Value
原.Cells(数, "J").Value = コピー.Range("B6").Value
原.Cells(数, "D").Value = コピー.Range("J22").Value
原.Cells(数, "E").Value = コピー.Range("J23").Value
原.Cells(数, "F").Value = コピー.Range("J24").Value
End With
Next
Next

'ブッククローズ処理
開.Close (False) '保存せずに閉じる
End If

フォルダ = Dir 'フォルダ内の次のbookを検索

Loop

Application.ScreenUpdating = True '画面ちらつき防止を解除

MsgBox 紙 & "件のファイルをコピーしました。"

End Sub

No.1 回答者： bin-chan 回答日時： 2013/03/07 23:08

パッと見ですが、複数のブック間でデータを扱うわりには

「xxのブックを指定する」が定義されていないように思います。

シートをselectする行の直前で、目的のブックを指定(select)する行を
加えてみてはいかが？

この回答への補足

bin-chanさま

アドバイスありがとうございます。

折角アドバイスいただいたのですが、VBAを今回初めて書いたためいまひとつ解らないのです。
出来れば、追加のマクロをいただけると嬉しいです

補足日時：2013/03/08 16:14

No.2 回答者： puddingeater 回答日時： 2013/03/08 01:29

おそらく"For 終" のループは要りません。

-------------------------------------
For 終 = 1 To 紙

数 = 数 + 1
'シートループ処理
For Each コピー In 開.Worksheets
--------------------------------------

ここはこうしたかったんじゃないかと思います。

--------------------------------------
'シートループ処理
数 = 1
For Each コピー In 開.Worksheets
数 = 数 + 1
--------------------------------------

それと、実行時に当日のシートが既にあった場合は使いまわしていますが、シート内容をクリアしなくても大丈夫でしょうか。
一度実行した後、フォルダ内のxlsファイルを減らしてから再実行すると前の結果が一部残ってしまうと思います。

この回答への補足

7981785さま

アドバイスありがとうございます。

アドバイスにしたがって色々模索した結果、何とか使えるようになりました。
ありがとうございました。

ただ、まだいくつかの問題は残っていて、その部分について追加マクロをいただけないでしょうか。
問題は3つです。

1.ご指摘のシートデータクリアなのですが、エラーになってしまうため、はずしたのですが、出来れば入れたいのです。何がダメなのでしょうか。

'存在する場合はシートデータクリア
原.Cells(2,1).Rsize(Rows.Count-1,Columns.Count).ClearContents

2.いくつか除きたいシートをはずすマクロを作成したのですが、これはスルーされてしまいます。

If コピー.Name<>"はじめに" Or コピー.Name<>"TAB" Then

また、シートどうやらもう一つ非表示(別表1)があり、全部で3つのシートを除きたいです。

どんなマクロを使ったらよいのでしょうか。

3.ファイルですが、どうやら開いて作業しているThisWorkbookを再度読み込んでしまうので(メッセージが出ます)、エラーになっているので、何とかしたいのです。
同じフォルダーに入っている除きたいファイルは2つあります。

集ファイル(ThisWorkbook)とjeという名前のファイルです。

何卒、アドバイス宜しくお願いいたします。


木村

補足日時：2013/03/08 16:11

No.3 回答者： puddingeater 回答日時： 2013/03/09 13:16

> 1.ご指摘のシートデータクリアなのですが、エラーになってしまうため、

> 原.Cells(2,1).Rsize(Rows.Count-1,Columns.Count).ClearContents

Rsize でなく Resize です。
それから、混乱を避らすため"原."を付けるかどうか統一しておいた方がいいと思います。
Cells(2,1).Rsize(Rows.Count-1,Columns.Count).ClearContents
にするか、
原.Cells(2,1).Rsize(原.Rows.Count-1,原.Columns.Count).ClearContents
にするか。


> 2.いくつか除きたいシートをはずすマクロを作成したのですが、これはスルーされてしまいます。
>If コピー.Name<>"はじめに" Or コピー.Name<>"TAB" Then

この場合<>を使うならOrでなくAndです。
If コピー.Name<>"はじめに" And コピー.Name<>"TAB" Then

> また、シートどうやらもう一つ非表示(別表1)があり、全部で3つのシートを除きたいです。
表示しているシートでも非表示のシートでもやり方は同じです。
他の２つの条件に
And コピー.Name<>"別表1"
を付け足したらいいです。


> 3.ファイルですが、どうやら開いて作業しているThisWorkbookを再度読み込んでしまうので

もとの質問にある、
> If フォルダ <> 集.Name Then 'book名がこのbookの名前でなければ
これで集ファイルが除けるはずなのですがうまくいきませんか？
条件を増やしたらおかしくなったということでしょうか。
JEも除くのはシート名の判定と同じくJEのファイル名を条件に付け足すだけです。

If フォルダ <> 集.Name And フォルダ <> "JEまとめ.xls" Then


それからNo2でうっかりForの直前に
数 = 1
を書いてますが、もう場所を直してもらってますかね。
Do Until より上にしてないとブックごとに"数"がリセットされてうまくいってないと思います。

この回答への補足

色々とアドバイスありがとうございます。

とっても助かりました。
問題なく動きました。

また、別の質問なのですが、このマクロを利用して(条件は同じ)今度は列単位のコピーをしたいのですが、下記のように変更するだけでは動かないのです。
何度もすみませんが、また、アドバイスいただけるとうれしいです。

With WorksheetFunction
原.Cells(数, "H").Value = コピー.Range("B1:B6").Value
原.Cells(数, "H").Value = コピー.Range("B10:B20").Value
End With

補足日時：2013/03/11 18:42

No.4 ベストアンサー 回答者： puddingeater 回答日時： 2013/03/14 01:01

回答が遅くなりました。

もう自己解決されてるかもしれませんが、一応。

> 下記のように変更するだけでは動かないのです。
> 原.Cells(数, "H").Value = コピー.Range("B1:B6").Value

6個の値をどのように入れようとされているのか分かりませんが、もし元と同じ並びのまま入れるのなら、行数・列数をもとの範囲と合わせる必要があります（上記の例だと"B1:B6"なので6行1列）。
コードの書き方は色々でしょうが、上記例に近い形を取るなら
原.Cells(数, "H").Resize(6, 1).Value = コピー.Range("B1:B6").Value
など。

もし縦横を入れ替える必要があるのなら、この書き方ではできません。
複数を一度に代入するのはあきらめてもとの質問のコードのように一つずつ入れていくか、次のようにコピー＆ペーストの機能を利用して縦横を入れ替えるのが楽だと思います。
コピー.Range("B1:B6").Copy
原.Cells(数, "H").Resize(1, 6).PasteSpecial Paste:=xlPasteValues, Transpose:=True
ここで、"Transpose"が縦横入れ替えのオプションです。

この回答へのお礼

本当に色々とアドバイス下さり、
ありがとうございました。

とっても助かりました。
また、何かございましたら、宜しくお願いいたします。

お礼日時：2013/03/18 09:40