データを別ブックに分割保存する処理（前半）記事の続きです。前半部分も是非ご覧ください
さて、この記事で完結できるか心配ですが書き始めていきます
前半のおさらいを兼ねてフローチャートをもう一回見てみます
前半（左半分）で一番重要なユニークデータを作成するところを解説しましたので、前半の解説していない部分と後半のループ処理部分を中心に解説をしていきます
グループごとのデータをフィルタを使って分割し別ブックに保存していく記事（前半）
「分割設定」シートを作成します
・これが「分割設定」シートです
・ここのシートで必要な設定データをすべて書き込めるようにしています
・こうすることで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 '指定がない場合１
'ターゲットファイルを開く
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は１からスタート
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
