エクセルで複数ファイルコピー保存

質問

こういうことがやりたいです。
１、新規ブック作成　２、1997フォルダー内の19970303日報1を開きA1:K38をコピーし新ブック（sheet1）A1に貼り付け、次に19970303日報2を開きB3:K36をコピーし新ブック（sheet1）L5に貼り付ける。名前をつけて保存（新ブックのK2をファイル名にする）。すべて閉じる。また1からはじめ、同じ作業を次のファイル19970304日報1、19970304日報2に対して行う。
　日報ファイルはファイル名が日付になっているため順番に並んでいます。またシートは１つです。
　前にこのサイトで教えていた大ことを参考に作ってみましたが、日報ファイルが開いてコピーまでは動いていますが、貼り付けができないです。また名前をつけて保存もできないです。
　初心者のため完全に理解して作っていなくておはづかしいですがご教授よろしくお願いします。
Sub copybook7()

Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim DataSht As Worksheet 'このブックの貼り付けシート
Dim i As Long '貼り付け行カウンタ

Workbooks.Add
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
With ActiveSheet.PageSetup
Range("A1:G1,L1:AG1").ColumnWidth = 9
Range("H1:K1,AH1").ColumnWidth = 12
End With
With ThisWorkbook
Set DataSht = .Worksheets(1)
myPath = "C:\1997\"
DataFile = Dir(myPath & "*.xls", vbNormal)
i = 1
Do While DataFile <> ""
If DataFile <> .Name And _
InStr(1, DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open( _
Filename:=myPath & DataFile, ReadOnly:=True)

If InStr(1, DataFile, "日報1") > 0 Then
copybook.ActiveSheet.Range("A1:K38").Copy
DataSht.Range("A1").PasteSpecial Paste:=xlAll

ElseIf InStr(1, DataFile, "日報2") > 0 Then
copybook.ActiveSheet.Range("B3:K36").Copy
DataSht.Range("L5").PasteSpecial Paste:=xlAll
Else
End If
Application.DisplayAlerts = False
copybook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set copybook = Nothing
End If
DataFile = Dir
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Range("K2") & "日報"
.Close
Loop
Set DataSht = Nothing
End With
End Sub

回答No.3

avanzato · ベストアンサー

#1です。
個人用マクロブック＝自分自身という意味です。
個人用マクロブックがどういう物かは分かりませんがとりあえず実行用のブックが日報と同じフォルダに入っているとして改修した以下のプログラムをお試しください。
Sub copybook7()
　　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, 9, 3)
　　　　　　　　Case "日報1"
　　　　　　　　　　Workbooks.Add
　　　　　　　　　　NewBook = ActiveWorkbook.Name
　　　　　　　　　　With Workbooks(NewBook).ActiveSheet
　　　　　　　　　　　　.PageSetup.PrintTitleRows = ""
　　　　　　　　　　　　.PageSetup.PrintTitleColumns = ""
　　　　　　　　　　　　.Range("A1:G1,L1:AG1").ColumnWidth = 9
　　　　　　　　　　　　.Range("H1:K1,AH1").ColumnWidth = 12
　　　　　　　　　　End With
　　　　　　　　　　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").Copy
　　　　　　　　　　Workbooks(NewBook).ActiveSheet.Range("L5").PasteSpecial Paste:=xlAll
　　　　　　　　　　Application.CutCopyMode = False
　　　　　　　　　　CopyBook.Close
　　　　　　　　　　Application.DisplayAlerts = False
　　　　　　　　　　NewFileName = Workbooks(NewBook).ActiveSheet.Range("K2").Value & "日報.xls"
　　　　　　　　　　Workbooks(NewBook).SaveAs MyPath & NewFileName
　　　　　　　　　　Application.DisplayAlerts = True
　　　　　　　　　　Workbooks(NewFileName).Close
　　　　　　End Select
　　　　End If
　　　　DataFile = Dir
　　Loop
　　MsgBox ("完了")
End Sub

補足

ありがとうございます。
日報ファイルが開くだけです。
新規のファイルを作り、それに既存のファイルの内容をコピーし名前を付けて保存。また新規のファルを作り、そこへ次の既存のファイルをコピーし名前を付けて保存という作業なのですが、、、。

回答No.6

avanzato

#1です。
NewFileName = Workbooks(NewBook).ActiveSheet.Range("K2").Value & "日報.xls"
を次のように変更してください。
NewFileName = Format(Workbooks(NewBook).ActiveSheet.Range("K2").Value, "yyyymmdd") & "日報.xls"

K2の値が日付であれば「20100203日報.xls」と言う名前になります。

補足

ありがとうございました。
完成しました。長々とお付き合いくださり本当に助かりました。
これからもよろしくお願いします。

回答No.5

hige_082

こんな感じでは？

Sub copybook7()
Dim myPath As String 'このブックのパス
Dim DataFile As String 'Dir()で開くブック名
Dim copybook As Workbook '開いたブック
Dim AddBook As Workbook '新規book
Dim i As Long '貼り付け行カウンタ
myPath = "C:\1997\"
DataFile = Dir(myPath & "*.xls", vbNormal)
Do While DataFile <> ""
If DataFile <> .Name And _
InStr(1, DataFile, "日報") > 0 Then
Set copybook = Application.Workbooks.Open( _
Filename:=myPath & DataFile, ReadOnly:=True)
If InStr(1, DataFile, "日報1") > 0 Then
copybook.Worksheets(1).Copy
Set AddBook = ActiveWorkbook
ElseIf InStr(1, DataFile, "日報2") > 0 Then
With AddBook.Worksheets(1)
copybook.Worksheets(1).Range("B3:K36").Copy AddBook.Worksheets(1).Range("l5")
.PageSetup.PrintTitleRows = ""
.PageSetup.PrintTitleColumns = ""
.Range("A1:G1,L1:AG1").ColumnWidth = 9
.Range("H1:K1,AH1").ColumnWidth = 12
AddBook.SaveAs Filename:=myPath & Format(.Range("K2").Value, "yyyymmdd") & "日報" _
, FileFormat:=xlNormal
End With
ActiveWindow.Close
Set AddBook = Nothing
End If
Application.DisplayAlerts = False
copybook.Close SaveChanges:=False
Application.DisplayAlerts = True
Set copybook = Nothing
End If
DataFile = Dir
Loop
End Sub

参考まで

回答No.4

avanzato

#1です。
補足を頂きました件ですが日報を開いているということは
Select Case Mid(DataFile, 9, 3)
の値が処理に影響していると思われます。
質問の中で「19970303日報1」とあったのでMIDで9文字目から3文字抜き取り処理をするようコーディングしました。
仮に199733日報1のようなファイル名があった場合は何も処理されないです。
Select Case Mid(DataFile, 9, 3)
を
Select Case Mid(DataFile, InStr(1, DataFile, "日報"), 3)
に変更して見てください。

一応こちらで数日分のデータを作り実行してみましたが正常な動作を確認しました。

お礼

すみませんようやく動きました。
只1つ問題なのは、ファイル名につける参照のセルが1997/03/03なので
このままではファイル名がつけられません。
方法としては
1.1997/03/03を別な表記に変えて保存する。
2.最初にコピーするブック名が970303日報1なので、このファイル名の　970303日報をファイル名にする。
3.970303日報1のファイル名のまま別なフォルダーに保存する。
お忙しいところすみません。よろしくお願いします。

補足

すみません省略してしまって。
開いたのは970303日報1・970303日報2、970304日報1・970304日報2・・・・と目的のファイルは開いたのですが、新規のブックに貼付けされていない、保存されていないということです。
　ちなみに、エクセルを起動して、PERSONAL.XLSB！copybook7()を実行すると、"完了"の表示だけがされます。970303日報1と同じフォルダー（1997）内にBOOK1を作りそれにプロシージャを登録して、それを開いて実行すると、970303日報1等のファイルは開くのですが、1997フォルダーには新規のファイルは保存されておらず、また、開いているBOOK1にも何も張り付けられていません。
どこがおかしいのでしょうか？

回答No.2

avanzato

#1です。
環境を合わせて実行してみましたが全体的に改修が必要ですので若干お時間を頂きます。
（他の方が回答されるのが早いかもしれませんが・・・。）

ご提示されておられるのコードの流れは現状以下のようになっています。
自分自身をＡとした時
新規ブックＺを作成しページ設定を行う。
Ａのシート1の名前をDataShtにセット。
フォルダ内のエクセルを読んでくる。
（最初に読み込まれたのが日報1と仮定）
日報1のA1:K38をコピーする。
ＡのDataShtのA1に貼り付けをする。
日報1を閉じる。
次のファイルを読んでくる。
Ａを～日報と言う名前で保存
Ａを閉じる。
この時点で新規ブックはページ設定が行われた状態で残りＡが終了する為マクロも停止。

ThisWorkbookとActiveWorkbookの使い方が間違っているだけかと思いましたが新規ブック作成のコードがループの外にある為仮に日報2を読んできたとしても貼り付けが出来なくなります。

補足

すみません、私の勘違いでしょうか、個人用マクロブックにプロシージャーを作り、何も開いていない状態で（自分自身Aが無い状態で新しいブックZを作り、、、という動作を考えていたのですが、これって間違いなのでしょうか？

回答No.1

avanzato

こんにちは。
現在動作確認を行っておりますが不明な点があります。
＞日報ファイルが開いてコピーまでは動いていますが
とありますが、その前に1回目のループで
With ThisWorkbook～.Close
で自身を終了していますがこれはActiveWorkbookの方かと思います。
新たに作った日報1枚を残して終了されていませんか？

補足

どうもありがとうございます。
すみません、完全に理解して作ったわけではないのでご迷惑をおかけします。
　自分としては、新たに作ったブックに日報１、日報２をコピーして
出来たブックのK2のセルをファイル名にして保存して閉じる。（全てを）
その後にまた新しいブックを作り次の日報１，２をコピーして,,,
という動作を考えているのですが、すみません見様見真似ですので
、、正直ご質問の”新たに作った日報1枚を残して終了されていませんか？”は自分でもわからないです。
　すみませんがよろしくお願いします。