Sub ファイル名連番作成()
Dim folderPath As String
Dim fileName As String
Dim newFileName As String
Dim maxNum As Long
Dim file As Object
Dim fso As Object
Dim i As Long
' フォルダーのパスを指定（例：C:\Users\yourname\Documents\ExcelFiles）
folderPath = "C:\YourFolderPath\"
' FileSystemObjectを使用してフォルダー内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダー内のファイルを順番に処理
maxNum = 0
For Each file In fso.GetFolder(folderPath).Files
' Excelブックのみを対象にする（拡張子が .xlsm または .xlsx）
If file.Name Like "*.xls*" Then
' ファイル名が "サンプル_2024-xxx" の形式になっていることを確認
If file.Name Like "サンプル_2024-###.xls*" Then
' 連番部分を抽出
i = Val(Mid(file.Name, Len("サンプル_2024-") + 1, Len(file.Name) - Len("サンプル_2024-") - 4))
If i > maxNum Then
maxNum = i
End If
End If
End If
Next file
' 新しいファイル名の作成
maxNum = maxNum + 1
newFileName = "サンプル_2024-" & Format(maxNum, "000") & ".xlsx"
' 新しいブックの作成
Workbooks.Add
' 新しいブックに保存
ActiveWorkbook.SaveAs folderPath & newFileName
' 作成したブックの Sheet1 にファイル名の連番を A1 に記載
ActiveWorkbook.Sheets(1).Range("A1").Value = "2024-" & Format(maxNum, "000")
' 完了メッセージ
MsgBox "新しいファイルが作成されました: " & newFileName
End Sub
Sub ファイル名連番作成2()
'/ひな形を基にbook作成する
Dim folderPath As String
Dim templateFile As String
Dim newFileName As String
Dim maxNum As Long
Dim file As Object
Dim fso As Object
Dim i As Long
Dim templateBook As Workbook
Dim sheet As Worksheet
' フォルダーのパスを指定（Zドライブの指定されたフォルダー）
folderPath = "C:\YourFolderPath\"
' ひな形ファイル名（例：Template.xlsx）
templateFile = folderPath & "ひな形.xlsx"
' FileSystemObjectを使用してフォルダー内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダー内のファイルを順番に処理
maxNum = 0
For Each file In fso.GetFolder(folderPath).Files
' ファイル名に "サンプル" を含むExcelファイルのみを対象
If file.Name Like "*サンプル*" And file.Name Like "*.xls*" Then
' ファイル名の連番部分を抽出（例：サンプル_2024-001.xlsx なら、001を抽出）
If file.Name Like "サンプル_2024-###.xls*" Then
i = Val(Mid(file.Name, Len("サンプル_2024-") + 1, Len(file.Name) - Len("サンプル_2024-") - 4))
If i > maxNum Then
maxNum = i
End If
End If
End If
Next file
' 新しいファイル名の作成
maxNum = maxNum + 1
newFileName = "サンプル_2024-" & Format(maxNum, "000") & ".xlsx"
' ひな形ファイルを開く
Set templateBook = Workbooks.Open(templateFile)
' 新しいファイル名で保存
templateBook.SaveAs folderPath & newFileName
' ひな形ファイルのシートを取得
On Error Resume Next
Set sheet = templateBook.Sheets("①")
On Error GoTo 0
' シートが存在する場合、G1に連番を記載
If Not sheet Is Nothing Then
sheet.Range("G1").Value = "2024-" & Format(maxNum, "000")
Else
MsgBox "シート「①」が見つかりません。"
End If
' 完了メッセージ
MsgBox "新しいファイルが作成されました: " & newFileName
' ひな形ファイルを閉じる（変更は保存する）
templateBook.Close SaveChanges:=True
End Sub
Sub ファイル名連番作成3()
'/ひな形を基にbook作成する,別ExcelbookのDataシート③複製処理
Dim folderPath As String
Dim templateFile As String
Dim newFileName As String
Dim maxNum As Long
Dim file As Object
Dim fso As Object
Dim i As Long
Dim templateBook As Workbook
Dim sheet As Worksheet
Dim dataFolderPath As String
Dim dataFile As String
Dim dataBook As Workbook
Dim dataSheet As Worksheet
' フォルダーのパスを指定（Zドライブの指定されたフォルダー）
folderPath = "C:\YourFolderPath\"
' ひな形ファイル名（例：Template.xlsx）
templateFile = folderPath & "ひな形.xlsx"
' 取得するデータファイルのフォルダーパスを指定（別フォルダ）
dataFolderPath = "C:\YourDataFolderPath\"
' FileSystemObjectを使用してフォルダー内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダー内のファイルを順番に処理
maxNum = 0
For Each file In fso.GetFolder(folderPath).Files
' ファイル名に "サンプル" を含むExcelファイルのみを対象
If file.Name Like "*サンプル*" And file.Name Like "*.xls*" Then
' ファイル名の連番部分を抽出（例：サンプル_2024-001.xlsx なら、001を抽出）
If file.Name Like "サンプル_2024-###.xls*" Then
i = Val(Mid(file.Name, Len("サンプル_2024-") + 1, Len(file.Name) - Len("サンプル_2024-") - 4))
If i > maxNum Then
maxNum = i
End If
End If
End If
Next file
' 新しいファイル名の作成
maxNum = maxNum + 1
newFileName = "サンプル_2024-" & Format(maxNum, "000") & ".xlsx"
' ひな形ファイルを開く
Set templateBook = Workbooks.Open(templateFile)
' 新しいファイル名で保存
templateBook.SaveAs folderPath & newFileName
' ひな形ファイルのシートを取得
On Error Resume Next
Set sheet = templateBook.Sheets("①")
On Error GoTo 0
' シートが存在する場合、G1に連番を記載
If Not sheet Is Nothing Then
sheet.Range("G1").Value = "2024-" & Format(maxNum, "000")
Else
MsgBox "シート「①」が見つかりません。"
End If
' ひな形ファイルのシート「③」に、別フォルダから「Data」シートの「③」を転記
On Error Resume Next
Set dataBook = Workbooks.Open(dataFolderPath & "DataBook.xlsx")
On Error GoTo 0
If Not dataBook Is Nothing Then
On Error Resume Next
Set dataSheet = dataBook.Sheets("③") ' データファイルのシート③を取得
On Error GoTo 0
If Not dataSheet Is Nothing Then
' シート③の内容をコピーして、ひな形ファイルのシート③に貼り付け
dataSheet.UsedRange.Copy Destination:=templateBook.Sheets("③").Range("A1")
Else
MsgBox "「③」シートが見つかりません。"
End If
' DataBookを閉じる
dataBook.Close SaveChanges:=False
Else
MsgBox "DataBook.xlsxが見つかりません。"
End If
' 完了メッセージ
MsgBox "新しいファイルが作成されました: " & newFileName
' ひな形ファイルを閉じる（変更は保存する）
templateBook.Close SaveChanges:=True
End Sub
Sub ファイル名連番作成4()
'/ひな形を基にbook作成する,別ExcelbookのDataシート②、③も複製処理
Dim folderPath As String
Dim templateFile As String
Dim newFileName As String
Dim maxNum As Long
Dim file As Object
Dim fso As Object
Dim i As Long
Dim templateBook As Workbook
Dim sheet As Worksheet
Dim dataFolderPath As String
Dim dataFile As String
Dim dataBook As Workbook
Dim dataSheet As Worksheet
Dim templateSheet2 As Worksheet
Dim lastRow As Long
' フォルダーのパスを指定（Zドライブの指定されたフォルダー）
folderPath = "Z:\Work\"
' ひな形ファイル名（例：Template.xlsx）
templateFile = folderPath & "ひな形.xlsx"
' 取得するデータファイルのフォルダーパスを指定（別フォルダ）
dataFolderPath = "Z:\Work\"
' FileSystemObjectを使用してフォルダー内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダー内のファイルを順番に処理
maxNum = 0
For Each file In fso.GetFolder(folderPath).Files
' ファイル名に "サンプル" を含むExcelファイルのみを対象
If file.Name Like "*サンプル*" And file.Name Like "*.xls*" Then
' ファイル名の連番部分を抽出（例：サンプル_2024-001.xlsx なら、001を抽出）
If file.Name Like "サンプル_2024-###.xls*" Then
i = Val(Mid(file.Name, Len("サンプル_2024-") + 1, Len(file.Name) - Len("サンプル_2024-") - 4))
If i > maxNum Then
maxNum = i
End If
End If
End If
Next file
' 新しいファイル名の作成
maxNum = maxNum + 1
newFileName = "サンプル_2024-" & Format(maxNum, "000") & ".xlsx"
' ひな形ファイルを開く
Set templateBook = Workbooks.Open(templateFile)
' 新しいファイル名で保存
templateBook.SaveAs folderPath & newFileName
' ひな形ファイルのシートを取得
On Error Resume Next
Set sheet = templateBook.Sheets("①")
On Error GoTo 0
' シートが存在する場合、G1に連番を記載
If Not sheet Is Nothing Then
sheet.Range("G1").Value = "2024-" & Format(maxNum, "000")
Else
MsgBox "シート「①」が見つかりません。"
End If
' ひな形ファイルのシート「③」に、別フォルダから「Data」シートの「③」を転記
On Error Resume Next
Set dataBook = Workbooks.Open(dataFolderPath & "DataBook.xlsx")
On Error GoTo 0
If Not dataBook Is Nothing Then
On Error Resume Next
Set dataSheet = dataBook.Sheets("③") ' データファイルのシート③を取得
On Error GoTo 0
If Not dataSheet Is Nothing Then
' シート③の内容をコピーして、ひな形ファイルのシート③に貼り付け
dataSheet.UsedRange.Copy Destination:=templateBook.Sheets("③").Range("A1")
Else
MsgBox "「③」シートが見つかりません。"
End If
' ' DataBookを閉じる
' dataBook.Close SaveChanges:=False
Else
MsgBox "DataBook.xlsxが見つかりません。"
End If
' dataBook.Sheets("②")のB2:C列の最終行を取得し、その範囲をコピーしてひな形ファイルのシート2に貼り付け
On Error Resume Next
Set dataSheet = dataBook.Sheets("②") ' DataBookのシート②を取得
On Error GoTo 0
If Not dataSheet Is Nothing Then
' B列の最終行を取得
lastRow = dataSheet.Cells(dataSheet.Rows.Count, "B").End(xlUp).Row
' B2:C列の最終行までをコピー
If lastRow >= 2 Then ' B2 からデータがある場合のみコピー
dataSheet.Range("B2:C" & lastRow).Copy
' ひな形ファイルのシート②に貼り付け
templateBook.Sheets("②").Range("B2").PasteSpecial Paste:=xlPasteValues
Else
MsgBox "B列にデータがありません。"
End If
Else
MsgBox "「②」シートが見つかりません。"
End If
' 完了メッセージ
MsgBox "新しいファイルが作成されました: " & newFileName
' ひな形ファイルを閉じる（変更は保存する）
templateBook.Close SaveChanges:=True
End Sub
Sub ファイル名連番作成5()
'/ひな形を基にbook作成する,別ExcelbookのDatabook③、Databook②も複製処理
Dim folderPath As String
Dim templateFile As String
Dim newFileName As String
Dim maxNum As Long
Dim file As Object
Dim fso As Object
Dim i As Long
Dim templateBook As Workbook
Dim sheet As Worksheet
Dim dataFolderPath1 As String ' Databook.xlsxがあるフォルダのパス
Dim dataFolderPath2 As String ' Databook2.xlsxがあるフォルダのパス
Dim dataBook1 As Workbook
Dim dataBook2 As Workbook
Dim dataSheet1 As Worksheet
Dim dataSheet2 As Worksheet
Dim lastRow As Long
' フォルダーのパスを指定（Zドライブの指定されたフォルダー）
folderPath = "C:\YourFolderPath\"
' ひな形ファイル名（例：Template.xlsx）
templateFile = folderPath & "ひな形.xlsx"
' 取得するデータファイルのフォルダーパスを指定（Databook.xlsxがあるフォルダ）
dataFolderPath1 = "C:\YourDataFolderPath1\"
' 別のデータファイルのフォルダーパスを指定（Databook2.xlsxがあるフォルダ）
dataFolderPath2 = "C:\YourDataFolderPath2\"
' FileSystemObjectを使用してフォルダー内のファイルを取得
Set fso = CreateObject("Scripting.FileSystemObject")
' フォルダー内のファイルを順番に処理
maxNum = 0
For Each file In fso.GetFolder(folderPath).Files
' ファイル名に "サンプル" を含むExcelファイルのみを対象
If file.Name Like "*サンプル*" And file.Name Like "*.xls*" Then
' ファイル名の連番部分を抽出（例：サンプル_2024-001.xlsx なら、001を抽出）
If file.Name Like "サンプル_2024-###.xls*" Then
i = Val(Mid(file.Name, Len("サンプル_2024-") + 1, Len(file.Name) - Len("サンプル_2024-") - 4))
If i > maxNum Then
maxNum = i
End If
End If
End If
Next file
' 新しいファイル名の作成
maxNum = maxNum + 1
newFileName = "サンプル_2024-" & Format(maxNum, "000") & ".xlsx"
' ひな形ファイルを開く
Set templateBook = Workbooks.Open(templateFile)
' 新しいファイル名で保存
templateBook.SaveAs folderPath & newFileName
' ひな形ファイルのシートを取得
On Error Resume Next
Set sheet = templateBook.Sheets("①")
On Error GoTo 0
' シートが存在する場合、G1に連番を記載
If Not sheet Is Nothing Then
sheet.Range("G1").Value = "2024-" & Format(maxNum, "000")
Else
MsgBox "シート「①」が見つかりません。"
End If
' ひな形ファイルのシート「③」に、Databook.xlsx（dataFolderPath1）からデータを転記
On Error Resume Next
Set dataBook1 = Workbooks.Open(dataFolderPath1 & "Databook.xlsx")
On Error GoTo 0
If Not dataBook1 Is Nothing Then
On Error Resume Next
Set dataSheet2 = dataBook1.Sheets("③") ' Databook.xlsx のシート③を取得
On Error GoTo 0
If Not dataSheet2 Is Nothing Then
' シート③の内容をコピーして、ひな形ファイルのシート③に貼り付け
dataSheet2.UsedRange.Copy Destination:=templateBook.Sheets("③").Range("A1")
Else
MsgBox "「③」シートが見つかりません。"
End If
' Databook.xlsxを閉じる
dataBook1.Close SaveChanges:=False
Else
MsgBox "Databook.xlsxが見つかりません。"
End If
' ひな形ファイルのシート②に、Databook2.xlsx（dataFolderPath2）のSheet1のデータを転記
On Error Resume Next
Set dataBook2 = Workbooks.Open(dataFolderPath2 & "Databook2.xlsx")
On Error GoTo 0
If Not dataBook2 Is Nothing Then
On Error Resume Next
Set dataSheet1 = dataBook2.Sheets("Sheet1") ' Databook2.xlsx のSheet1を取得
On Error GoTo 0
If Not dataSheet1 Is Nothing Then
' Sheet1のB2:C列の最終行を取得
lastRow = dataSheet1.Cells(dataSheet1.Rows.Count, "B").End(xlUp).Row
' B2:C列の最終行までをコピー
If lastRow >= 2 Then ' B2 からデータがある場合のみコピー
dataSheet1.Range("B2:C" & lastRow).Copy
' ひな形ファイルのシート②に貼り付け
templateBook.Sheets("②").Range("B2").PasteSpecial Paste:=xlPasteValues
Else
MsgBox "B列にデータがありません。"
End If
Else
MsgBox "「Sheet1」シートが見つかりません。"
End If
' Databook2.xlsxを閉じる
dataBook2.Close SaveChanges:=False
Else
MsgBox "Databook2.xlsxが見つかりません。"
End If
' 完了メッセージ
MsgBox "新しいファイルが作成されました: " & newFileName
' ひな形ファイルを閉じる（変更は保存する）
templateBook.Close SaveChanges:=True
End Sub
