シートを個別に保存

複数のシートを個別にファイルとして保存します。

 シート分けしていて個別ファイルとして保存したい時に役に立つと思います。

 対象とするブックをアクティブにした状態で実行すれば、ブック名＋シート名のファイル名称で保存されます。

 以下、プログラムは2003で作成したものになりますので、2007以降の4文字拡張子には対応してませんが、
その部分のプログラムを追記するか、もしくは NewFileName 変数への代入部分にある 4 を 5 に変更する事で
対応が可能です。

 Private Sub SaveAs_Sheet()  
 Dim YN As Integer     '確認用  
 Dim i As Long        'カウント  
 Dim m As Long       'カウント  
 Dim myFileName As String    '自ファイル名  
 Dim myPath As String       '自ファイルパス  
 Dim NewFileName As String   '新ファイル名  
 On Error GoTo er  
 '処理対象シートの確認  
   YN = MsgBox("処理対象ブック名 : " & ActiveWorkbook.Name, vbYesNo)  
   If YN = vbNo Then Exit Sub  
   myFileName = ActiveWorkbook.Name  'ブック名取得  
   myPath = ActiveWorkbook.Path    'ブックパス取得  
   Application.ScreenUpdating = False '画面更新停止  
   m = ActiveWorkbook.Worksheets.Count  
   For i = 1 To m 'シートの枚数分だけ繰り返し  
     Application.StatusBar = "ファイル保存中(" & i & "/" & m & ")"  
     Windows(myFileName).Activate '対象ブックをアクティブ  
     NewFileName = Left(myFileName, Len(myFileName) - 4) & "_" & _  
       ActiveWorkbook.Worksheets(i).Name 'ブック名とファイル名を合成  
     ActiveWorkbook.Worksheets(i).Copy '新しいブックにシートをコピー  
     Application.DisplayAlerts = False  '警告表示停止  
     ActiveWorkbook.SaveAs Filename:=myPath & "\" & NewFileName & ".xls" '新しいブックに名前をつけて保存  
     Application.DisplayAlerts = True  '警告表示再開  
     ActiveWorkbook.Close '保存終了後にブックを閉じる  
   Next i  
   Application.ScreenUpdating = True  '画面更新再開  
   Application.StatusBar = False  
   Exit Sub  
 er:  
 MsgBox Err.Description & "(" & Err.Number & ")"  
 End Sub
ラベル: ,