複数のブックコピーの繰り返しその２
このサイトのお力により以下のプロシージャができました。
折角作っていただいたのですが、処理枚数が増えたため１ファイルに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
補足
例がシートのインデックスだったので誤解させてしまったかもしれませんが 私が知りたいのは、ブックのインデックスです。シートのインデックスではありません