【Excel VBA】データを別ブックに分割保存する処理(後半)

スポンサーリンク

データを別ブックに分割保存する処理(前半)記事の続きです。前半部分も是非ご覧ください

さて、この記事で完結できるか心配ですが書き始めていきます
前半のおさらいを兼ねてフローチャートをもう一回見てみます

前半(左半分)で一番重要なユニークデータを作成するところを解説しましたので、前半の解説していない部分と後半のループ処理部分を中心に解説をしていきます

グループごとのデータをフィルタを使って分割し別ブックに保存していく記事(前半)

スポンサーリンク

「分割設定」シートを作成します

・これが「分割設定」シートです
・ここのシートで必要な設定データをすべて書き込めるようにしています
・こうすることでVBAコードを書き換えることなく「汎用」で使えるようにしています
・二つの「ボタン」で「ファイル指定」「フォルダ指定」のコードを呼び出すようにしています

注)この記事の内容にない項目も一部含まれています(ZIPファイル作成部分)
  「ZIPファイル作成」についても別途記事にしていこうと思います

分割方法の検証中に問題点発生

・フローチャートでは元データで分割処理を行う記述となっていますが
・検証を行った分割方法は二つありました

① 元ブックから指定シートのみをコピーして分割する方法

・シンプルで高速処理できる

・ある設定の場合「リンク」が切れない問題が発覚!!
・問題が発生する状況がなかなか再現できませんでしたが、やっと見つけました!
「データの入力規則」でリスト設定を別シートのデータから行っていた場合です!
リンクを削除してから分割しても、保存時にリンクが復活してしまいます!
・考えられる色々な方法を試しましたがすべて✖
・Google先生に調べてもらいましたがHIT無しでした

② 元ブックで指定シートを分割する方法

・この方法では、すべての設定をそのまま引き継ぐので問題は全くありません
・隠しシートなどもすべて引き継げます
・必要ならば、不要なシートを削除する設定を追加する

ということで、この方法①は捨てることにしました
方法②を利用して、指定シート以外を削除するように調整していきます

データを別ブックに分割保存するコード

少し長いですが我慢してご覧ください

分割処理部分のコードはこちらです

'**************************************************************************
' 分割パターン(2)元ファイルで直接作業してブックごとに分割名で保存する処理
' (ZIPファイル作成処理はカット)
'**************************************************************************
Sub SplitFile_2(flgSep As Long)
    Dim MyWb As Workbook, mySh As Worksheet
    Dim wb As Workbook, wb2 As Workbook
    Dim sh0 As Worksheet, sh1 As Worksheet
    Dim StNm As String
    Dim n As Long, i As Long 'ループ処理用
    Dim Ph As String, Fp As String 'パスとフルパス用
    Dim Fnflg  As Long, tgCol As Long, tgRow As Long
    Dim strRow  As String, strDelRow As String
    Dim wDelflg As Long
    Dim strPw As String, strPwSet As String 'Password解除とセット用
    Dim TgetSh As Long
    Dim lnFlg As Long
    Dim NewFileName As String
    Dim NewFullFileName As String
    
    Set MyWb = ThisWorkbook
    Set mySh = MyWb.Worksheets("分割設定")
    Call マクロ開始
    '設定をセットする
    With mySh
        Fnflg = .Range("C20")       '分割後ファイル名の指定
        tgCol = 1                   '項目列の指定(初期値)
        If .Range("G10") <> Empty Then tgCol = .Range("G10")
        tgRow = 1                   '列見出し行の指定(初期値)
        If .Range("G11") <> Empty Then tgRow = .Range("G11")
        strRow = "1:" & tgRow       '列見出し行までの行指定用
        If tgRow = 1 Then           '列見出し行を除く行指定用
            strDelRow = "1:" & tgRow
        Else: strDelRow = "1:" & tgRow - 1
        End If
        wDelflg = .Range("G12")     '空白行の処理指定フラグ
        Ph = .Range("G2")           '保存フォルダ指定
        strPw = .Range("C18")       'パスワード解除用
        strPwSet = .Range("C19")    'パスワードセット用
        TgetSh = .Range("C21")      '分割するシート数
        If TgetSh = 0 Then TgetSh = 1 '指定がない場合1
        'ターゲットファイルを開く
        If Dir(.Range("G6")) <> "" Then
            Set wb = Workbooks.Open(Filename:=.Range("G6"), UpdateLinks:=0, Password:=strPw)
        Else
            MsgBox "ファイルが存在しません。", vbExclamation
        End If
    End With
    wb.Activate                     '開いた元ブック
    Set sh0 = wb.ActiveSheet        'wbのアクティブシートをセット
    Fp = wb.FullName                '元ブックのフルパスとパス
    '保存フォルダの指定がない場合元ブックと同じフォルダを指定
    If Ph = "" Then Ph = wb.Path
    '元ブック内のアクティブシートが合っているかチェック
    StNm = sh0.Name
    With mySh
        If StNm <> .Range("G21") Then
            StNm = .Range("G21")
            Set sh0 = wb.Sheets(StNm)
            sh0.Activate
        End If
        '作業シートを一時的にセット
        Set sh1 = .Parent.Worksheets.Add
    End With
    
    '重複しないリストを格納する処理(Collection使用)
    Dim uKeys As New Collection 'Collectionオブジェクト
    Dim u As Long
    With sh1
        .Columns(1).Value = sh0.Columns(tgCol).Value
        .Range(.Cells(1, 1), .Cells(tgRow, 1)).Delete Shift:=xlUp '項目なしで
        On Error Resume Next   'データ重複エラーを無視する
        For u = 1 To .Cells(1, 1).CurrentRegion.Count
            uKeys.Add .Cells(u, 1).Value, .Cells(u, 1).Value
        Next
        On Error GoTo 0
    End With
    sh1.Delete
    Set sh1 = Nothing
    For n = 1 To uKeys.Count    'Collectionは1からスタート
        lnFlg = 0
        For i = 1 To TgetSh
            If TgetSh >= 1 Then StNm = mySh.Cells(21, 5 + i * 2)
            With wb.Sheets(StNm)
                .Activate
                '列見出し行までのデータをworkシートに保存
                .Rows(strRow).Copy
                MyWb.Sheets("work").Rows(strRow).PasteSpecial Paste:=xlPasteAll
                '列見出し行を残してデータを一旦削除
                If tgRow > 1 Then .Rows(strDelRow).Delete
                'uKeys(n)以外をフィルタで表示
                .Rows(1).AutoFilter tgCol, "<>" & uKeys(n)
                '表示領域削除(列見出し行も含めて)
                Application.DisplayAlerts = False
                If wDelflg = 0 Then
                    .Cells.Delete
                Else: .Range("A1").CurrentRegion.Delete
                End If
                Application.DisplayAlerts = True
                'uKeys(n)だけ残る
                .AutoFilterMode = False
                If .Cells(1, tgCol) <> uKeys(n) Then
                    .Cells(1, tgCol) = "対象データなし"
                Else
                    lnFlg = lnFlg + 1 'データがある場合intFlgに+1追加
                End If
                '1行目に列見出し行を挿入
                MyWb.Sheets("work").Rows(strRow).Copy
                .Range(strRow).Insert Shift:=xlDown
                .Range("A1").Select
            End With
        Next
        '不要なシートを削除する場合の処理【SplitFile_1】不具合への対処
        If flgSep <> 1 Then Call BreakLinkShCut
        'ブックを別名で保存
        NewFileName = uKeys(n)
        If Fnflg = 1 Then
            'エラーの場合は指定前の名前で保存
            On Error Resume Next
            NewFileName = WorksheetFunction.VLookup(uKeys(n), mySh.Range("X:Z"), 3, False)
            On Error GoTo 0
        End If
        NewFullFileName = Ph & "\" & NewFileName & ".xlsx"
        wb.SaveAs Filename:=NewFullFileName, Password:=strPwSet
        '保存したブックを別のオブジェクトwb2へ退避
        Set wb2 = wb
        Set wb = Nothing
        '元のブックを再度開きなおしてオブジェクトwbへ格納
        Set wb = Workbooks.Open(Filename:=Fp, UpdateLinks:=0, Password:=strPw)
        '別名保存したブックを閉じる(シートがなかった場合は削除する)
        wb2.Close
        Set wb2 = Nothing
    Next
    Set uKeys = Nothing
    '開いた元のブックを閉じる
    wb.Close savechanges:=False
    Call マクロ終了
    MyWb.Activate
    mySh.Activate
    Set MyWb = Nothing
    Set mySh = Nothing
End Sub

・すみません(^^; さすがに長いですよね でもちゃんと動きます
ファイル名を指定する部分の解説は省略しています(X:Z列で設定)
サンプルファイルで動作確認してみてください(^-^;

処理スタート部分のコード

・ここからスタートさせています(不具合部分は分岐せずにフラグをセットして対処しています

'**************************************************************************
' 分割はここからスタート_処理方法を分岐(SplitFile_1への分岐は一時中止!)
'**************************************************************************
Sub SplitStart()
    Dim flgSep As Long
    Dim strDir As String
    Dim rc As Long

    strDir = Range("G2")
    intZip = Range("G13")
    If Dir(strDir & "\*.xls*") <> "" Then              '分割後保存先フォルダ
        rc = MsgBox("保存先フォルダにExcelファイルがあります。" & vbCrLf & _
                    "ファイルを全て削除して実行を継続しますか?" & vbCrLf & _
                    "(はい=削除して実行 ; いいえ=中止)", vbYesNo + vbExclamation, "確認")
        If rc = vbYes Then
            Kill strDir & "\*.xls*"  '拡張子が .xls* のすべてのファイルを削除
        Else
            Exit Sub
        End If
        'ファイルが存在しない場合は何もしない(そのまま実行)
    End If
    flgSep = Range("C17")
'    If flgSep = 1 Then
        Call SplitFile_2(flgSep)
'    Else: Call SplitFile_1
'    End If
    MsgBox "ファイルの分割が完了しました。", vbInformation
End Sub

リンク解除とシート削除用コード(不具合対処用)

・このコードで他ブックへのリンク解除(BreakLink)とシート削除を行います

'他ブックへのリンク解除とActiveシート以外を削除する
Sub BreakLinkShCut()
    Dim xlstrLinks As Variant
    Dim strLins As Variant
    Dim mySh As Worksheet

    '他ブックへのリンクがあるかどうか調べる
    xlstrLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
    If xlstrLinks <> Empty Then
        For Each strLink In xlstrLinks
            'リンクを解除する
            ActiveWorkbook.BreakLink Name:=strLink, Type:=xlLinkTypeExcelLinks
        Next
    End If
    'アクティブシートをすべて削除
    With Application
        .DisplayAlerts = False  '確認メッセージを非表示に
        'シート名をチェックして、アクティブシートでなければ削除
        For Each mySh In Worksheets
            If mySh.Name <> ActiveSheet.Name Then mySh.Delete
        Next
        .DisplayAlerts = True   '非表示解除
    End With
End Sub

まとめ

後半部分の「まとめ」と感想

・テスト段階で思わぬ不具合が発覚したので対処に時間がかかりました
・とりあえず①「SplitFile_1」のコードを捨てて対処するように設定しました
・分かりやすく解説するつもりでしたがグダグダになってしまい申し訳ありません
サンプルファイルで動作検証していただけるとありがたいでです
今回は「フローチャート」を提示してみましたがこれが基本ですよね(^^;

次回の記事、そして今後は

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです
サンプルファイルを用意していますので下記リンクからご利用ください

【今後の記事内容はどうしようかなぁ・・・】
・ExcelからOutlook 2016でメールを送信する方法
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・その他「小ネタ」などなど・・・・・
・今後これらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

前回の記事とあわせてサンプルファイルをアップしますm(_ _)m

記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください