Option Explicit
'------------------------------------------------------------
' 設定（ここだけ編集すればシート名・セル番地を変更可能）
' ※ご指定の名称を元に、VBA識別子として有効な形に調整しています。
' （例: "1名..." のように先頭が数字になる名前は "申請1名..." に変更）
'------------------------------------------------------------
Private Const テンプレート設定シート As String = "Sheet1" ' 元: CONFIG_SHEET1_NAME
Private Const 申請書作成方法設定シート As String = "Sheet2" ' 元: CONFIG_SHEET2_NAME
' Sheet1 上のセル（テンプレートファイルパスは種別により参照）
Private Const 申請1名テンプレートファイルパス As String = "B2" ' 元: 1名申請書テンプレートファイルパス (ユーザ指定)
Private Const 複数申請テンプレートファイルパス As String = "B3" ' 元: 複数申請書テンプレートファイルパス (ユーザ指定)
Private Const 一時フォルダパス As String = "B4" ' 元: 一時フォルダパス (ユーザ指定)
Private Const 本格納フォルダパス As String = "B5" ' 元: 本格納フォルダパス (ユーザ指定)
' Sheet2 上のセル
Private Const 申請対象者人数設定 As String = "B1" ' 元: 申請対象者人数設定 (ユーザ指定) -> 値は "1名" または "複数"
Private Const オフィス名設定 As String = "B2" ' 元: オフィス名設定 (ユーザ指定) -> ファイル名に付加する文字列
'------------------------------------------------------------
' メイン処理
'------------------------------------------------------------
Sub コピーリネーム移動_設定対応()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim テンプレートファイルパス As String
Dim 一時フォルダ As String, 本格納フォルダ As String
Dim fso As Object
Dim テンプレート拡張子 As String, テンプレベース名 As String
Dim 一時フルパス As String, リネームフルパス As String, 最終フルパス As String
Dim 種別 As String, 名称付加 As String
Dim 日付文字列 As String
On Error GoTo ErrHandler
Set wb = ThisWorkbook
' --- シート取得（設定に従う） ---
If Not SheetExists(テンプレート設定シート, wb) Then
MsgBox "設定で指定されたシートが見つかりません: " & テンプレート設定シート, vbExclamation
Exit Sub
End If
If Not SheetExists(申請書作成方法設定シート, wb) Then
MsgBox "設定で指定されたシートが見つかりません: " & 申請書作成方法設定シート, vbExclamation
Exit Sub
End If
Set ws1 = wb.Worksheets(テンプレート設定シート)
Set ws2 = wb.Worksheets(申請書作成方法設定シート)
' --- 入力取得（設定に従う） ---
種別 = Trim(ws2.Range(申請対象者人数設定).Value) ' "1名" または "複数"
If 種別 = "1名" Then
テンプレートファイルパス = Trim(ws1.Range(申請1名テンプレートファイルパス).Value)
ElseIf 種別 = "複数" Then
テンプレートファイルパス = Trim(ws1.Range(複数申請テンプレートファイルパス).Value)
Else
MsgBox "申請対象者人数設定セルの値が不正です。""1名"" または ""複数"" を指定してください。", vbExclamation
Exit Sub
End If
名称付加 = Trim(ws2.Range(オフィス名設定).Value) ' ファイル名に付加する文字列
一時フォルダ = Trim(ws1.Range(一時フォルダパス).Value)
本格納フォルダ = Trim(ws1.Range(本格納フォルダパス).Value)
' --- 基本チェック ---
If テンプレートファイルパス = "" Then
MsgBox "テンプレートファイルパスが空です。設定セルを確認してください。", vbExclamation
Exit Sub
End If
If 一時フォルダ = "" Or 本格納フォルダ = "" Then
MsgBox "一時フォルダまたは本格納フォルダが空です。設定セルを確認してください。", vbExclamation
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(テンプレートファイルパス) Then
MsgBox "テンプレートファイルが見つかりません: " & テンプレートファイルパス, vbExclamation
Exit Sub
End If
If Not fso.FolderExists(一時フォルダ) Then
MsgBox "一時フォルダが存在しません（自動作成は行いません）: " & 一時フォルダ, vbExclamation
Exit Sub
End If
If Not fso.FolderExists(本格納フォルダ) Then
MsgBox "本格納フォルダが存在しません（自動作成は行いません）: " & 本格納フォルダ, vbExclamation
Exit Sub
End If
' --- 元ファイル情報 ---
テンプレート拡張子 = LCase(fso.GetExtensionName(テンプレートファイルパス)) ' ドット無し
テンプレベース名 = fso.GetBaseName(テンプレートファイルパス)
' --- 一時フォルダへコピー（元ファイル名で） ---
一時フルパス = fso.BuildPath(一時フォルダ, fso.GetFileName(テンプレートファイルパス))
If fso.FileExists(一時フルパス) Then
一時フルパス = GetUniquePath(fso, 一時フォルダ, テンプレベース名, テンプレート拡張子)
End If
fso.CopyFile テンプレートファイルパス, 一時フルパス, False
' --- リネーム名作成（種別に応じて） ---
日付文字列 = Format(Date, "yyyy.MM.dd")
名称付加 = SanitizeFileName(名称付加)
If 名称付加 <> "" Then
If テンプレート拡張子 <> "" Then
リネームフルパス = fso.BuildPath(一時フォルダ, _
IIf(種別 = "1名", "1名申請(", "複数申請(") & 日付文字列 & ")" & 名称付加 & "." & テンプレート拡張子)
Else
リネームフルパス = fso.BuildPath(一時フォルダ, _
IIf(種別 = "1名", "1名申請(", "複数申請(") & 日付文字列 & ")" & 名称付加)
End If
Else
If テンプレート拡張子 <> "" Then
リネームフルパス = fso.BuildPath(一時フォルダ, _
IIf(種別 = "1名", "1名申請(", "複数申請(") & 日付文字列 & ")." & テンプレート拡張子)
Else
リネームフルパス = fso.BuildPath(一時フォルダ, _
IIf(種別 = "1名", "1名申請(", "複数申請(") & 日付文字列 & ")")
End If
End If
' --- リネーム時の同名回避 ---
If fso.FileExists(リネームフルパス) Then
Dim baseForRename As String
baseForRename = fso.GetBaseName(リネームフルパス)
リネームフルパス = GetUniquePath(fso, 一時フォルダ, baseForRename, テンプレート拡張子)
End If
' 同一フォルダ内の名前変更
fso.MoveFile 一時フルパス, リネームフルパス
' --- 本格納へ移動（同名回避） ---
最終フルパス = fso.BuildPath(本格納フォルダ, fso.GetFileName(リネームフルパス))
If fso.FileExists(最終フルパス) Then
Dim baseForFinal As String
baseForFinal = fso.GetBaseName(リネームフルパス)
最終フルパス = GetUniquePath(fso, 本格納フォルダ, baseForFinal, テンプレート拡張子)
End If
fso.MoveFile リネームフルパス, 最終フルパス
MsgBox "処理が完了しました。" & vbCrLf & "本格納先: " & 最終フルパス, vbInformation
Exit Sub
ErrHandler:
Select Case Err.Number
Case 70
MsgBox "アクセスが拒否されました。ファイルが開かれているか、権限を確認してください。", vbCritical
Case 53
MsgBox "ファイルが見つかりません。パスを確認してください。", vbCritical
Case Else
MsgBox "エラーが発生しました。Err:" & Err.Number & " - " & Err.Description, vbCritical
End Select
End Sub
'------------------------------------------------------------
' 補助関数群（変更不要）
'------------------------------------------------------------
Private Function SheetExists(sheetName As String, wb As Workbook) As Boolean
On Error Resume Next
Dim sh As Worksheet
Set sh = wb.Worksheets(sheetName)
SheetExists = Not sh Is Nothing
On Error GoTo 0
End Function
Private Function GetUniquePath(fso As Object, folderPath As String, baseName As String, ext As String) As String
Dim candidate As String
Dim n As Long
If ext <> "" Then
candidate = fso.BuildPath(folderPath, baseName & "." & ext)
Else
candidate = fso.BuildPath(folderPath, baseName)
End If
If Not fso.FileExists(candidate) Then
GetUniquePath = candidate
Exit Function
End If
n = 1
Do
If ext <> "" Then
candidate = fso.BuildPath(folderPath, baseName & "-" & CStr(n) & "." & ext)
Else
candidate = fso.BuildPath(folderPath, baseName & "-" & CStr(n))
End If
If Not fso.FileExists(candidate) Then
GetUniquePath = candidate
Exit Function
End If
n = n + 1
If n > 10000 Then Err.Raise vbObjectError + 513, "GetUniquePath", "連番上限に達しました。"
Loop
End Function
Private Function SanitizeFileName(namePart As String) As String
Dim i As Long
Dim badChars As String
badChars = "\/:*?""<>|"
If namePart = "" Then
SanitizeFileName = ""
Exit Function
End If
For i = 1 To Len(badChars)
namePart = Replace(namePart, Mid(badChars, i, 1), "_")
Next i
SanitizeFileName = Trim(namePart)
End Function
未分類
コメント