同じフォルダのファイルを一括にする

Sub 一括ファイル作成()
Dim MOTODATA As String
Dim SWB As Workbook, TOUGOUGO As Workbook
Dim SHEETNOCount As Long
Dim i As Long
Dim SOURCE_DIR As String
Dim SNAME As String


C = Range("b11").Value
R = Range("d11").Value


SOURCE_DIR = ThisWorkbook.Path & "\"




Application.ScreenUpdating = False

'指定したフォルダ内にあるブックのエクセルファイル名を取得
'MOTODATA = Dir(SOURCE_DIR & "*.xls")
MOTODATA = Dir(SOURCE_DIR & "*.xlsx")



'フォルダ内にブックがなければ終了
If MOTODATA = "" Then Exit Sub

'集約用ブックを作成
Set TOUGOUGO = Workbooks.Add

'シート数を取得
SHEETNOCount = TOUGOUGO.Worksheets.Count

Do
'コピー元のブックを開く
Set SWB = Workbooks.Open(Filename:=SOURCE_DIR & MOTODATA)

'コピー元のシート1をコピー
SWB.Sheets(1).Copy After:=TOUGOUGO.Worksheets(SHEETNOCount)

'シート名を変更
On Error Resume Next


ActiveSheet.Name = ActiveSheet.Range(C & R).Value



'コピー元ファイルを閉じる
SWB.Close

'次のブックのファイル名を取得
MOTODATA = Dir()
Loop While MOTODATA <> ""



'作業シート
Application.DisplayAlerts = False
For i = SHEETNOCount To 1 Step -1
TOUGOUGO.Worksheets(i).Delete
Next i
Application.DisplayAlerts = True




t = Format(Now, "hhnn")
'TOUGOUGO.SaveAs ThisWorkbook.Path & "\" & Filename & t & ".xls", FileFormat:=XlFileFormat.xlExcel8

TOUGOUGO.SaveAs ThisWorkbook.Path & "\" & "一括(" & t & ").xlsx"
TOUGOUGO.Close
'作成したファイルを閉じる場合↑

MsgBox ThisWorkbook.Path & "に出力しました。"

Application.ScreenUpdating = False
スポンサーサイト

コメントの投稿

非公開コメント

プロフィール

とも

Author:とも
FC2ブログへようこそ!

最新記事
最新コメント
最新トラックバック
月別アーカイブ
カテゴリ
FC2カウンター
検索フォーム
RSSリンクの表示
リンク
QRコード
QR