複数のブックコピーの繰り返しその２

　このサイトのお力により以下のプロシージャができました。
折角作っていただいたのですが、処理枚数が増えたため１ファイルに1日分だったのが３日分（６ファイル）をコピーすることになってしまいました。どのようにしたらよいでしょうか、お分かりの方いらっしゃいましたらよろしくお願いします。
　現状は、あるフォルダー内のファイル970303日報1、970303日報2を開いて、新しいブックに貼りつけて保存する。次に970304日報1、970304日報2を開いて新しいブックに貼りつけて保存するという作業の繰り返しです。
　これを、970303日報1,2　970304日報1,2　970305日報1,2の3日分を新しいブックにコピーして保存する。次に970306日報1,2　970307日報1,2　970308日報1,2を新しいブックにコピーして保存する。これの繰り返しをしたいのですがどうしたらよいでしょうか。
　ファイルのコピーする範囲は一定です。貼り付けるブックのセルは
１日目の日報１がA1、日報2がL5、2日目の日報1がA40、日報2がL44
3日目の日報1がA79、日報2がL83となります。
　すみませんよろしくお願いします。
Sub copybook11()
Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim NewBook As String '新しいブック
Dim NewFileName As String '新しいファイル名
myPath = ThisWorkbook.Path & "\"
DataFile = Dir(myPath & "*.xls", vbNormal)
Do While DataFile <> ""
If DataFile <> ThisWorkbook.Name And InStr(1,
　　　　DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open
　　　　(Filename:=myPath & DataFile, ReadOnly:=True)
Select Case Mid(DataFile, InStr(1, DataFile, "日
　　　　　報"), 3)
Case "日報1"
Workbooks.Add
NewBook = ActiveWorkbook.Name
copybook.ActiveSheet.Range("A1:K38").copy
Workbooks(NewBook).ActiveSheet.Range
　　　　　　　　　　("A1").PasteSpecial paste:=xlAll
Application.CutCopyMode = False
copybook.Close
Case "日報2"
copybook.ActiveSheet.Range
　　　　　　　　　　("B3:K36,T3:U36").copy
Workbooks(NewBook).ActiveSheet.Range
　　　　　　　　　　("L5").PasteSpecial paste:=xlAll
Application.CutCopyMode = False
copybook.Close
NewFileName = Format(Workbooks
　　(NewBook).ActiveSheet.Range("k2").Value, "yyyymmdd") & "日
　　　報.xls"
Workbooks(NewBook).SaveAs Filename:=myPath
　　　　　　　　　　& NewFileName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
Workbooks(NewFileName).Close
End Select
End If
DataFile = Dir
Loop
End Sub

No.1 回答者： hige_082 回答日時： 2010/02/07 05:26

前回の解決から、数日で変更ですか

ご自分でも分っていると思いますが
初心者には、まだ難しいと思いますよ
必要ならば、専門業者にでも頼んでは如何？

変更部分のみ
Case "日報1"
If NewBook Is Nothing Then
copybook.ActiveSheet.Copy
Set NewBook = ActiveWorkbook
Else
With NewBook.ActiveSheet
copybook.ActiveSheet.Range("A1:K38").Copy .Range("A40")
If .Range("a40").Value = "" Then
.Range("a40").PasteSpecial Paste:=xlAll
Else
.Range("a79").PasteSpecial Paste:=xlAll
End If
End With
End If
copybook.Close
Case "日報2"
With NewBook.ActiveSheet
copybook.ActiveSheet.Range("B3:K36,T3:U36").Copy
If .Range("l5").Value = "" Then
.Range("L5").PasteSpecial Paste:=xlAll
ElseIf .Range("l44").Value = "" Then
.Range("L44").PasteSpecial Paste:=xlAll
Else
.Range("L83").PasteSpecial Paste:=xlAll
copybook.Close
NewFileName = Format(.Range("k2").Value, "yyyymmdd") & "日報.xls"
NewBook.SaveAs Filename:=myPath & NewFileName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
NewBook.Close
End If
End With

エラー等は考慮していません
最低限の変更しかしてませんので・・悪しからず