表を新しいブックに保存
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
お礼
おー ありがとうございます。この手がありましたね。思い付きませんでした。 Dim max as long max=Rows.Count Range("B3:C" & max & ",L3:M" & max).Select としても同じですよね。