■総合的な目的の前提（以下の内容を網羅するExcelマクロ） 以下のような条件を想定して作ったExcelマクロです
前提
●元ファイルから、特定のシートを選択して新しいExcelファイルを作成する
●元ファイルには、一切の変更を加えない
●元ファイルの指定は、該当のファイル、個人用マクロブックどちらからでも実行可能
⇒アクティブになっているExcelファイルを対象元として扱う
●保存先は、元ファイルの同一階層フォルダ。
⇒保存前で元フォルダのパスが無い時（保存されてない場合）はドキュメントフォルダに保存
⇒ドキュメントフォルダは、パブリックではなくサインイン中のユーザーフォルダ
●書き出し先ファイルは、マクロ内上部の指定箇所で管理しやすい
●特定のシート選択は、マクロ内上部の指定箇所で管理しやすい
想定条件
●元ファイルには、シート毎に相互に参照設定が施されている
●書き出し先と、元ファイルの中で参照がされている場合は、値で書出して参照させない
●書出し先内（シートどうし）で参照設定されている場合は、そのままにする
●書出し先のシートでの入力規制（リストからのプルダウン等）は解除しない
●書出し先のシートに、フィルタ設定がされていても、解除しない
限定的な条件
●複数のパターンセットが考えられるので、Privateでマクロを隠さない
●後から管理が面倒（呼出し元の不明など）にならないように、Functionは使わない
●1モジュール内に、1プロシージャで書ける様に記述する
●プロシージャ内のsubや、コピーするシート、書出しファイル名だけの書き換えで管理する
良ければ以下をコピーして使ってみてください。部分的にコピペでも効果的に使えると思います。（不要な行やコメントアウトは適宜削除して使ってください）
Option Explicit
‘=================================================
‘ 目的：
‘ アクティブなブック（= コピー元 / 元ファイル）から、
‘ 指定したシートのみを新規ブックとしてコピーし、
‘ 参照状態を下記ルールで整理して保存する。
‘
‘ 【参照整理ルール】
‘ 1) コピー先シート同士の参照は維持（外部参照 → 内部参照へ置換）
‘ 例）=[元ファイル.xlsm]Sheet10!C8 → =Sheet10!C8 （式は保持）
‘
‘ 2) コピー先以外のシート・元ファイルへの参照は値確定
‘ c.Value = c.Value により、数式 → 値へ変換（入力規則・フィルタは維持）
‘
‘ 3) セル外に残る外部リンク（定義名/グラフ/検証のリスト参照等）は
‘ BreakLink により、元ファイルへの依存を完全排除
‘
‘ 【保存先ルール】
‘ – 原則：元ファイルと同じフォルダへ保存
‘ – ただし、元ファイルが未保存 または 保存先フォルダが存在しない場合：
‘ → サインイン中ユーザーの「ドキュメント」フォルダへ保存
‘ ※ Public ではなく、ユーザー固有の My Documents を使用
‘
‘ 配置先：PERSONAL.XLSB（個人用マクロブック）推奨
‘ 実行時：コピー元となる 元ファイル をアクティブにしてから実行
‘=================================================
Public Sub Export_Set_テンプレート()'==================== 設定（この3行だけ変更すればよい） ==================== Dim 出力名 As String: 出力名 = "コピー出力.xlsx" '← 保存ファイル名（拡張子未指定なら自動で .xlsx 付与） Dim コピーシート As String: コピーシート = "Sheet2,Sheet3,Sheet10," '← カンマ区切り。末尾カンマOK Const 上書き禁止 As Boolean = False '← Trueにすると、既存同名ファイルがある場合は日時付きで別名保存 '========================================================================== '▼ ここから下は原則いじらない ------------------------------ Dim wbOrg As Workbook ' 元ファイル（コピー元） Dim wbNew As Workbook ' 新規作成されるブック（コピー先） Dim ws As Worksheet ' シートループ用 Dim savePath As String ' 保存先フルパス Dim orgWbName As String ' 元ファイル名（例："Sample.xlsm"） Dim userDocs As String ' 現ユーザーのドキュメントフォルダ Dim rngF As Range ' 数式セル範囲 Dim c As Range ' セルループ Dim f As String ' 数式文字列 Dim TARGET_SHEETS As Variant ' コピー対象シート配列 Dim tmpArr As Variant ' Split中間配列 Dim buf() As String ' 空要素除去後の配列 Dim i As Long, n As Long ' ループカウンタ等 Dim links As Variant ' LinkSources結果 Dim tryPath As String ' 保存時の一時パス On Error GoTo ErrHandler ' 予期せぬエラー捕捉 '▼ 元ファイル（アクティブブック）を取得 Set wbOrg = ActiveWorkbook '▼ 元ファイル名を取得（参照式置換・値化判定に使用） orgWbName = wbOrg.Name '▼ 出力名に拡張子が無い場合は自動で .xlsx を付与 If InStr(1, 出力名, ".", vbTextCompare) = 0 Then 出力名 = 出力名 & ".xlsx" End If '▼ 文字列 → 配列（Split）し、Trim & 空要素除去して TARGET_SHEETS を確定 tmpArr = Split(コピーシート, ",") ' 一旦カンマで分割 n = -1 For i = LBound(tmpArr) To UBound(tmpArr) Dim s As String s = Trim$(CStr(tmpArr(i))) ' 前後空白除去 If Len(s) > 0 Then ' 空要素は捨てる（末尾カンマ等に耐性） n = n + 1 If n = 0 Then ReDim buf(0 To 0) Else ReDim Preserve buf(0 To n) End If buf(n) = s End If Next i If n = -1 Then MsgBox "コピー対象シートが指定されていません（空です）。", vbExclamation Exit Sub End If TARGET_SHEETS = buf ' 最終的なコピー対象リスト '▼ 現ユーザーのドキュメントフォルダ（Publicではなく個人用） userDocs = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") '▼ 保存先フォルダの存在に応じて保存パスを決定 If wbOrg.Path = "" Then savePath = userDocs & "\" & 出力名 Else savePath = wbOrg.Path & "\" & 出力名 If Dir(wbOrg.Path, vbDirectory) = "" Then savePath = userDocs & "\" & 出力名 End If End If '▼ 上書き禁止の場合、同名ファイルが既に存在していれば日時付きに変更 If 上書き禁止 Then If Dir(savePath, vbNormal) <> "" Then savePath = Left$(savePath, Len(savePath) - 5) & _ "_" & Format(Now, "yyyymmdd_HHMMSS") & ".xlsx" End If End If '▼ 実行最適化：画面更新停止 + 保存確認ダイアログ抑止 Application.ScreenUpdating = False Application.DisplayAlerts = False '▼ 指定シートのみを新規ブックとしてコピー（順序は配列の並びどおり） wbOrg.Worksheets(TARGET_SHEETS).Copy Set wbNew = ActiveWorkbook '==================== 参照の整理（外部 → 内部 → 値化） ==================== For Each ws In wbNew.Worksheets '--- シート内の「数式セルのみ」を抽出（数式が無いとエラー→吸収） On Error Resume Next Set rngF = ws.UsedRange.SpecialCells(xlCellTypeFormulas) On Error GoTo 0 '--- 数式セルが無ければ次のシートへ If rngF Is Nothing Then GoTo NextSheet '--- (1) 元ファイル参照のうち、コピー先同士の参照は内部参照へ置換して式を保持 ' 例：=[元ファイル.xlsm]Sheet3!A1 → =Sheet3!A1 For i = LBound(TARGET_SHEETS) To UBound(TARGET_SHEETS) rngF.Replace _ What:="[" & orgWbName & "]" & CStr(TARGET_SHEETS(i)) & "!", _ Replacement:=CStr(TARGET_SHEETS(i)) & "!", _ LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False Next i '--- (2) 置換後の数式セルを再取得（式が更新されているため） On Error Resume Next Set rngF = ws.UsedRange.SpecialCells(xlCellTypeFormulas) On Error GoTo 0 '--- (3) 依然として数式内に [元ファイル] が残るセル（= コピー外参照）は値確定 If Not rngF Is Nothing Then For Each c In rngF.Cells f = CStr(c.Formula) If InStr(1, f, "[" & orgWbName & "]", vbTextCompare) > 0 Then c.Value = c.Value '数式 → 値（入力規則・フィルタは維持） End If Next c End IfNextSheet:
Set rngF = Nothing
Next ws'--- (4) セル外（定義名 / グラフ系列 / 検証のリスト参照 等）に残る元ファイル参照も BreakLink で除去 On Error Resume Next links = wbNew.LinkSources(Type:=xlLinkTypeExcelLinks) If Not IsEmpty(links) Then For i = LBound(links) To UBound(links) If InStr(1, CStr(links(i)), orgWbName, vbTextCompare) > 0 Then wbNew.BreakLink Name:=links(i), Type:=xlLinkTypeExcelLinks End If Next i End If On Error GoTo 0 '==================== 新規ブックを保存 ==================== tryPath = savePath wbNew.SaveAs Filename:=tryPath, FileFormat:=xlOpenXMLWorkbookCleanExit:
‘▼ 後片付け：表示系設定を元へ
Application.DisplayAlerts = True
Application.ScreenUpdating = True'▼ 完了通知 MsgBox "新しいブックを保存しました：" & vbCrLf & tryPath, vbInformation Exit SubErrHandler:
‘▼ エラー時の後片付けと通知
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox “エラー発生：” & Err.Description, vbExclamationEnd Sub
コメント