はじめに
T4exf63です。
前回に引き続き、職場で使えそうな簡易的なツールの投稿です。
ここ1週間Qiitaに張り付いている人か私のファンでしたら気づかれると思いますが、
実は前に投稿したタイトルが『【VBA】ファイル作成ツール（簡易）』と今回も同じタイトルなので
1週間足らずで同じタイトルで投稿してどんだけネタがないんだと思うかもしれませんが、これには理由があります。
前回投稿したものはファイルじゃなくてフォルダを作るものだったのですが、間違えたタイトル名で投稿していたので、今回のものが正しいタイトルです。
前回の方はタイトル・文書ともに修正したので、今見てもらったら修正されていると思いますが念のためご連絡です。
因みに前回投稿したものは以下です。
本題
今回はVBAのファイル作成ツールです。
これこそタイトル通りです。ちゃんとフォルダじゃなくファイルを作ります。
こちらもコピペですぐに使えます。
・開発環境
Microsoft Windows 11 Home
Microsoft Visual Basic for Application 7.1
・エクセルシート
基本的にシート内容は前回同様で、エクセルのフォーマットは以下です。
セルA：項番
セルB：ディレクトリ名（文末に￥があってもなくても可）
セルC：作成ファイル名
セルD：拡張子（文頭に.があってもなくても可）
※拡張子がない場合拡張子なしのファイルを作る
セルE：作成有無（〇・×）
セルF：備考（作成失敗時、原因出力）
・コード
Sub testCreateNewFile()
'====================================
'変数宣言
'====================================
Dim filePath As String 'ファイルパス（セルB）
Dim fileExtension As String '拡張子（セルD）
Dim FullFileName As String '拡張子込みのファイル名（セルC+セルD）
Dim fileNumber As Integer 'ファイル番号（ファイルオープン・クローズで使用）
Dim i As Integer 'ループ用
Dim flg As Integer '備考（セルF）内容判定用（0:正常、1以上:エラー）
Dim wb As Workbook 'excel作成時用 ワークブック
'初期化
i = 0
'====================================
'作成対象がなくなるまで繰り返す
'====================================
Do Until Cells(3 + i, 2).Value = ""
'初期化
FullFileName = ""
filePath = ""
fileExtension = ""
'====================================
'ディレクトリの文末の"\"確認
'====================================
If Right(Cells(3 + i, 2).Value, 1) <> "\" Then
filePath = Cells(3 + i, 2).Value & "\"
End If
'====================================
'拡張子有無判定
'====================================
If Cells(3 + i, 4).Value <> "" Then
'拡張子の欄に値がある場合
'拡張子の先頭の"."確認
If Left(Cells(3 + i, 4).Value, 1) = "." Then
fileExtension = Cells(3 + i, 4).Value
Else
fileExtension = "." & Cells(3 + i, 4).Value
End If
End If
'拡張子込みのファイル名を生成
FullFileName = Cells(3 + i, 3).Value & fileExtension
'====================================
'ファイルの存在確認
'====================================
If Len(Dir(filePath & FullFileName)) > 0 Then
flg = 1
Else
'作成ファイルがエクセルファイルか確認
If fileExtension = ".xlsm" Or fileExtension = ".xltx" Or fileExtension = ".xltm" Or fileExtension = ".xls" Or fileExtension = ".xlt" Or fileExtension = ".xls" Or fileExtension = ".XML" Then
'====================================
'エクセルファイルの場合
'====================================
'新しいエクセルブックを作成
Set wb = Workbooks.Add
'ファイルを保存する
Select Case fileExtension
Case ".xlsm"
'（xlsm：マクロ有効ファイル）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Case ".xltx"
'（xltx：テンプレートファイル）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLTemplate
Case ".xltm"
'（xltm：マクロ有効なExcelテンプレート）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLTemplateMacroEnabled
Case ".xls"
'（.xls：Excelバイナリ形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlExcel8
Case ".xlt"
'（xlt：Excelテンプレート)）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlTemplate
Case ".xml"
'（xml：XML形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlXMLSpreadsheet
Case ".xlsb"
'（xlsb：Excelバイナリ形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlExcel12
End Select
'新しいワークブックを閉じる
ActiveWorkbook.Close SaveChanges:=True
Else
'====================================
'エクセルファイル以外の場合
'====================================
'新しいファイルを作成
On Error Resume Next
fileNumber = FreeFile
Open filePath & FullFileName For Output As fileNumber
If Err.Number <> 0 Then
flg = 2
End If
End If
Close fileNumber
End If
'====================================
'処理結果判定
'====================================
If flg = 0 Then
'正常の場合
Cells(3 + i, 5).Value = "〇"
Cells(3 + i, 6).Value = "-"
ElseIf flg = 1 Then
'既に同名のファイルが存在する場合の処理
Cells(3 + i, 5).Value = "×"
Cells(3 + i, 6).Value = "ファイルが既に存在します。"
ElseIf flg = 2 Then
Cells(3 + i, 5).Value = "×"
Cells(3 + i, 6).Value = "ファイルの作成に失敗しました。"
Err.Clear
End If
flg = 0
i = i + 1
Loop
MsgBox "ファイルが完了しました。"
End Sub
・コード説明
殆どコメントで記述していますが、自分用に作成意図等の備忘録として残します。
・ここはエクセルファイルかを判定しています。本当であれば他にもエクセルファイルの拡張子がありますが、面倒だったので使用頻度が高そうなもの7つだけに絞りました。
If fileExtension = ".xlsm" Or fileExtension = ".xltx" Or fileExtension = ".xltm" Or fileExtension = ".xls" Or fileExtension = ".xlt" Or fileExtension = ".xls" Or fileExtension = ".XML" Then
else
endif
・ここではエクセルファイルの作成ですが、拡張子ごとにファイルフォーマット違うらしく、『FileFormat:=******』のところに該当するフォーマット名を入れています。
多分普通に調べたら出てくる、シート作成方法だと下記の2つがあると思いますが、ファイルフォーマットを指定しないこの方法で作れるのはエクセルのデフォルト拡張子の『xlsx』だけみたいです。
【ThisWorkbook.SaveAs Filename:="ファイルフルパス"】
【ActiveWorkbook.SaveAs fileName:=フルパス & ファイル名】
ファイルを保存する
Select Case fileExtension
Case ".xlsm"
'（xlsm：マクロ有効ファイル）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Case ".xltx"
'（xltx：テンプレートファイル）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLTemplate
Case ".xltm"
'（xltm：マクロ有効なExcelテンプレート）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlOpenXMLTemplateMacroEnabled
Case ".xls"
'（.xls：Excelバイナリ形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlExcel8
Case ".xlt"
'（xlt：Excelテンプレート)）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlTemplate
Case ".xml"
'（xml：XML形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlXMLSpreadsheet
Case ".xlsb"
'（xlsb：Excelバイナリ形式）
ActiveWorkbook.SaveAs fileName:=filePath & FullFileName, FileFormat:=xlExcel12
End Select
おわりに
今回作ろうと思ったら2か所面倒ところがあって、1つはエクセルファイルの拡張子を調べてみたら、14種類も出てきたことです。
年代によって拡張子が違うのは知っていたのですが14はさすがに多すぎる。
2つ目は、普通にファイル作成をしたらエクセルファイルを作れると思っていたことです。
普通のテキストファイルの要領で作ればいいだろうと適当に作ってみたらエクセルで開けない謎ファイルが完成して困惑しました。
エクセルはちゃんとエクセルアプリからちゃんと作らないといけないんですね。。。
今回のは個人的にそこまで必要性があまりなかったので必要最低限のテストしかしていないです。
なので、その辺もご了承を。
記：2023年5月14日