【コピペで使える】VBAでシートを分割保存

ブック内のシートを別ブックとして保存する用のマクロを作成しました！

梅屋

手動で「シートコピー＆保存」を永遠と
繰り返したら気が狂いそうになったので
VBA化しちゃいました！

どこに需要があるのかわかりませんが、コピペで使えるので興味がある方は使ってやって下さい…(汗)

もしかしたら事務職で役立てるかもしれません…。

30日間無料登録できる「Amazonプライム会員」に登録すれば、翌日に購入した商品が届くお急ぎ便・お届け日時指定便の指定ができるので、荷物をなるべく早く受け取りたい人にオススメ！

無料体験期間中もAmazonプライムビデオや1億曲以上聞き放題のAmazon Musicなど、すべてのプライム会員特典がセットになっています！

　　30日間の無料体験はこちら！　　

うめ

30日間以内に解約すれば費用は発生しません！

関連記事はこちら
ツールの流れ
ソースはこちら

ツールの流れ

動作確認用として10シート追加したブックを使用しています！

１、ツールを実行

２、分割するブックを指定

３、保存先のフォルダの名前を入力
※入力後にフォルダが自動生成されます。

４、デスクトップに指定したフォルダが生成され、フォルダ内に分割したブックが出力されます。
※シート名＝ブック名になります。

ソースはこちら

Sub sheets_split()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

MsgBox "分割するブックを指定してください。", vbInformation

Dim path As String, WSH As Variant, OpenFileName As String, fname As String
Set WSH = CreateObject("WScript.Shell")

path = WSH.SpecialFolders("Desktop") & "\"
ChDir path

fname = Application.GetOpenFilename

If fname <> "False" Then

    Workbooks.Open Filename:=fname
    
    Else
    
    MsgBox "キャンセルされました。もう一度分割するブックを指定してください。", vbInformation
    Exit Sub

End If

'保存先を確認
Dim ans As String

label1:
ans = InputBox("保存するフォルダ名を入力してください。(自動生成)", "保存先指定", "")

'デスクトップに指定したフォルダがなければ作成
If ans <> "" Then

        If Dir(path & ans, vbDirectory) = "" Then
                MkDir path & "\" & ans
            
            Else
            
                MsgBox "フォルダ名が重複しています。別の名前を設定してください。", vbInformation
                GoTo label1
        
        End If
        
    Else
    
    Dim rc As VbMsgBoxResult
    rc = MsgBox("キャンセルしました。ファイル分割を続けますか？", vbYesNo)
    
    If rc = vbNo Then
    
        ActiveWorkbook.Close
        MsgBox "分割を中止します。", vbInformation
        Exit Sub
        
    Else
        GoTo label1
        
    End If
            
End If

Dim sh As Worksheet

For Each sh In Worksheets

    sh.Copy
    ActiveWorkbook.SaveAs path & ans & "\" & sh.Name
    ActiveWorkbook.Close

Next sh

ActiveWorkbook.Close

MsgBox "終了しました！", vbInformation

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Sub sheets_split()

Application.ScreenUpdating = False

Application.DisplayAlerts = False

MsgBox "分割するブックを指定してください。", vbInformation

Dim path As String, WSH As Variant, OpenFileName As String, fname As String

Set WSH = CreateObject("WScript.Shell")

path = WSH.SpecialFolders("Desktop") & "\"

ChDir path

fname = Application.GetOpenFilename

If fname <> "False" Then

Workbooks.Open Filename:=fname

Else

MsgBox "キャンセルされました。もう一度分割するブックを指定してください。", vbInformation

Exit Sub

End If

'保存先を確認

Dim ans As String

label1:

ans = InputBox("保存するフォルダ名を入力してください。(自動生成)", "保存先指定", "")

'デスクトップに指定したフォルダがなければ作成

If ans <> "" Then

If Dir(path & ans, vbDirectory) = "" Then

MkDir path & "\" & ans

Else

MsgBox "フォルダ名が重複しています。別の名前を設定してください。", vbInformation

GoTo label1

End If

Else

Dim rc As VbMsgBoxResult

rc = MsgBox("キャンセルしました。ファイル分割を続けますか？", vbYesNo)

If rc = vbNo Then

ActiveWorkbook.Close

MsgBox "分割を中止します。", vbInformation

Exit Sub

Else

GoTo label1

End If

Dim sh As Worksheet

For Each sh In Worksheets

sh.Copy

ActiveWorkbook.SaveAs path & ans & "\" & sh.Name

ActiveWorkbook.Close

Next sh

ActiveWorkbook.Close

MsgBox "終了しました！", vbInformation

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

関連記事はこちら

ツールの流れ

ソースはこちら

コメント