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
お礼
さっそく試してみます！ お早い回答ありがとうございました＾＾ 今月中なので助かりました～＞＜