表を新しいブックに保存

質問

Sub 表を新しいブックに保存反映日ごと()

Application.ScreenUpdating = False

Dim フルパス As String, ファイル名 As String, パス As String, 新ファイル名 As String
新ファイル名 = ActiveSheet.Name
フルパス = ActiveWorkbook.FullName
ファイル名 = Dir(フルパス)
'パスを取得
パス = Replace(フルパス, ファイル名, "")

'表の範囲選択をする
Range("A1").Select
Dim 行数 As Long, 列数 As Long
行数 = 1
列数 = 1

Do While Cells(行数, 1) <> ""
行数 = 行数 + 1
Loop
行数 = 行数 - 1
Do While Cells(1, 列数) <> ""
列数 = 列数 + 1
Loop
列数 = 列数 - 1
Range(Cells(1, 1), Cells(行数, 列数)).Select

Selection.Copy

'新しいブックを開く
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Do While Range("A2") <> ""

Range("A1").Select

'一番上の発売日の範囲を取得
Range("A2").Select

Dim 列 As Long
Dim i As Long

列 = 1

'列数を取得
Do While Cells(1, 列) <> ""
列 = 列 + 1
Loop
列 = 列 - 1

'発売日ごとのデータ量を取得
i = 2
Do Until Cells(i, 1) <> Range("A2").Value
i = i + 1
Loop
i = i - 1

'発売日のまとまりのデータ範囲を選択
Range(Cells(1, 2), Cells(i, 列)).Select

'発売日ごとのデータをコピー
Selection.Copy

'発売日を取得
Dim 発売日 As Long
発売日 = Range("A2").Value

'新しいブックを追加してシート名を発売日に設定
Workbooks.Add
ActiveSheet.Name = 発売日
新ファイル名 = ActiveSheet.Name

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

'シート名をファイル名にして保存
ActiveWorkbook.SaveAs Filename:=パス & "メンテ_" & 新ファイル名 & ".xls", _
FileFormat:=xlExcel8, _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
Range("A1").Select

'保存された発売日分のデータを削除
Range(Cells(2, 1), Cells(i, 列)).Select
Selection.Delete Shift:=xlUp

Loop

'不要になった表転記用ブックを閉じる
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
Range("A1").Select

Application.ScreenUpdating = True
End Sub

Sub 表を新しいブックに保存()

Application.ScreenUpdating = False

Dim フルパス As String, ファイル名 As String, パス As String, 新ファイル名 As String
新ファイル名 = ActiveSheet.Name
フルパス = ActiveWorkbook.FullName
ファイル名 = Dir(フルパス)
'パスを取得
パス = Replace(フルパス, ファイル名, "")

'表の範囲選択をする
Range("A1").Select
Dim 行数 As Long, 列数 As Long
行数 = 1
列数 = 1

Do While Cells(行数, 1) <> ""
行数 = 行数 + 1
Loop
行数 = 行数 - 1
Do While Cells(1, 列数) <> ""
列数 = 列数 + 1
Loop
列数 = 列数 - 1
Range(Cells(1, 1), Cells(行数, 列数)).Select

Selection.Copy

'新しいブックを開く
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select

'シート名をファイル名にして保存
ActiveWorkbook.SaveAs Filename:=パス & 新ファイル名 & ".xls", _
FileFormat:=xlExcel8, Password:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
Range("A1").Select

Application.ScreenUpdating = True

End Sub

回答No.2

imogasi

何がしたいか文章に独立して記述せずに、回答者にこんな長いコードを読ませて、意図を解析させるのは、おかしいのではないか。
雇われVBAの教師ではない。
ーー
日々積み重なるデータを別シートにして、シートが多数ある場合は、指定シート１つだけを含んだ、独立ブックにする機能（VBAでも）はない。
ーー
ビジネスでは、普通は色んな意味とか、必要性から、各日のデータをシートなりに収めて、保存する（ブック）のではないか。
システムの専門家（エクセルなど使わないにしろ）にどうすべきか、相談したら。エクセルのVBAのことよりも、上位の必要かどうかの重要事項だと思う。

回答No.1

mt2015

Sub Anser()
　　MsgBox "それで、質問は何でしょう？"
End Sub