こんにちは。ナガオカ（@boot_kt）です。
もうそろそろ無くなっただろうなぁ・・・と思わせておきながら、意外としぶとく生き残りが見つかるのがxlsファイル
xlsxじゃなくて、xlsファイル！！
今のExcelはxlsファイルを読み込めるので特に問題は無いと思うけど、ビミョ～にイラッと来る時があるんだよねぇ・・・
この記事のザックリした内容
◆対象読者
- Excel VBAでファイル一覧やフォルダ一覧を取得したい（サブディレクトリも含む）人
- VBAの知識は必要
- オマケ：大量のxlsファイルをxlsxファイルに変換したい人
◆解決できるかも知れないお悩み
- マクロファイル置いているので、VBAでファイル一覧やフォルダ一覧を取得する方法と再帰処理が分かります
- オマケ：大量のxlsファイルをxlsxファイルに変換する方法
◆どうやって解決するか
- VBAを説明します
xlsmのマクロファイルとサンプルファイルを置いてますので実際に使いながら試せます
ダウンロードして使って戴いても結構ですが、動作については一切保証できません！
ご利用になる場合は自己責任でお使いください
ファイル一覧を取得する方法
以下の方法でファイル一覧やフォルダ一覧を取得できます
この方法が一番分かりやすくてスッキリと書けるんじゃないかなと思っています
Public Sub GetAllFiles(ByVal strDir As String)
' FileSystemObjectは参照設定でMicrosoft Scripting Runtimeが必要
Dim fso As New FileSystemObject
Dim fil As File
Dim fol As Folder
' strDir には対象のフォルダのフルパス
' このフォルダ直下のファイルを一つずつ処理する
For Each fil In fso.GetFolder(strDir).Files
Next
' このフォルダ直下のフォルダを一つずつ処理する
For Each fol In fso.GetFolder(strDir).SubFolders
Call GetAllFiles(strDir & "\" & fol.Name)
Next
End Sub
大量のxlsファイルをxlsxに変換するツール
ってことで、大量のxlsファイルをxlsxに変換するツールを作ってみた！！
その名もHenkan！
ソースコードは以下に挙げておきます
興味のある方はご覧ください
Option Explicit
Private M_FileCnt As Long
'--------------------------------------------------------
' ログ関係
'--------------------------------------------------------
Private M_LogFileNo As Long
Private Const M_LOGFILENAME As String = "LoggerConvert.log"
'********************************************************
' 各コントロールのイベントハンドラ
'********************************************************
'========================================================
' 変換ボタン
'========================================================
Private Sub cmdConvert_Click()
On Error GoTo ERR_ROUTIN
Dim strSearchPath As String
'--------------------------------------------------------
' ログオープン
'--------------------------------------------------------
Call LoggerOpen
Call LoggerOut("**** start ****")
strSearchPath = txtsearchbox.text
If (Trim(strSearchPath) = vbNullString) Then
Call MsgBox("パスを入力してください")
Call LoggerOut("ABBEND, Path was Nothing.")
Exit Sub
End If
If (Dir(strSearchPath, vbDirectory) = vbNullString) Then
' ディレクトリが存在しない場合
Call MsgBox("パスを入力してください")
Call LoggerOut("ABBEND, Path was Nothing.")
Exit Sub
End If
' 処理ファイル数をクリア
M_FileCnt = 0
' 画面更新停止
If (chkDialog.Value = True) Then
' Excelのダイアログを抑止する場合のみ、画面更新を停止する（処理が早くなるので）
Application.ScreenUpdating = False
Call LoggerOut("ScreenUpdating is False.")
' Excelの出すダイアログを抑制（無視）する
Application.DisplayAlerts = False
Call LoggerOut("Dialog was checked.")
End If
'--------------------------------------------------------
' 拡張子変更保存処理（再帰処理になっているので注意）
'--------------------------------------------------------
Call RenameFunction(strSearchPath, 1)
GoTo END_ROUTIN
ERR_ROUTIN:
Call LoggerOut("エラーが発生しました！：" & Error(Err))
Call MsgBox("エラーが発生しました！：" & Error(Err), vbOKOnly + vbCritical + vbExclamation)
END_ROUTIN:
Call LoggerOut("終了しました：" & CStr(M_FileCnt) & "個のファイルを処理しました")
Call MsgBox("終了しました：" & CStr(M_FileCnt) & "個のファイルを処理しました", vbOKOnly + vbInformation)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'--------------------------------------------------------
' ログクローズ
'--------------------------------------------------------
Call LoggerClose
End Sub
'========================================================
' 検索文字のテキストボックス（フォーカスを得た時イベント）
'========================================================
Private Sub txtSearchBox_GotFocus()
With txtsearchbox
.SelStart = 0
.SelLength = Len(.text)
End With
End Sub
'========================================================
' 検索文字のテキストボックス（キーダウンイベント）
'========================================================
Private Sub txtSearchBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = Asc(vbCr) Then
Call cmdConvert_Click
End If
End Sub
'========================================================
' ワークシートのどこかをクリックしたら、検索文字のテキストボックスへフォーカスを渡す
'========================================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
txtsearchbox.Activate
End Sub
'********************************************************
' 処理
'********************************************************
'========================================================
' リネーム処理
'========================================================
Public Sub RenameFunction(ByVal strDir As String, ByVal lngLevel As Long)
' FileSystemObjectは参照設定でMicrosoft Scripting Runtimeが必要
Dim fso As New FileSystemObject
Dim fil As File
Dim fol As Folder
Dim strFileName As String
Call LoggerOut("[" & CStr(lngLevel) & "]Dir:" & strDir)
' このフォルダ直下のファイルを一つずつ処理する
For Each fil In fso.GetFolder(strDir).Files
'--------------------------------------------------------
' 処理をOSへ戻す
' 処理時間が長くなるが、大量ファイル処理時の固まり防止
'--------------------------------------------------------
DoEvents
Call LoggerOut("[" & CStr(lngLevel) & "]" & Space(2 * lngLevel) & "File is " & fil.Name)
' ファイル名取得
strFileName = fil.Name
Dim splitFileName As String
Dim splitFileExt As String
Call SplitNameAndExt(strFileName, splitFileName, splitFileExt)
' 拡張子xlsのみチェック
If (LCase(splitFileExt) = "xls") Then
' ファイルを開く
Workbooks.Open strDir & "\" & strFileName
' 開いたファイルのオブジェクトを取得 → 別名保存（xlsxにする） → 閉じる
Dim wBook As Workbook
Set wBook = Workbooks(strFileName)
wBook.SaveAs Filename:=strDir & "\" & splitFileName & ".xlsx", FileFormat:=XlFileFormat.xlWorkbookDefault
wBook.Close
Call LoggerOut("[" & CStr(lngLevel) & "]" & Space(2 * lngLevel) & "SaveAs " & strDir & "\" & splitFileName & ".xlsx")
' 処理したファイルの数をインクリメント
Call incrementFileCnt
' ファイル削除
If (chkDelete.Value = True) Then
Call LoggerOut("[" & CStr(lngLevel) & "]" & Space(2 * lngLevel) & "Deleted " & strDir & "\" & strFileName)
Kill strDir & "\" & strFileName
End If
End If
Next
' サブフォルダも対応するチェックが入っている時
If (chkSaiki.Value = True) Then
' このフォルダ直下のファイルが全て終わったので、
' このフォルダにあるサブフォルダを一つずつ対応する
For Each fol In fso.GetFolder(strDir).SubFolders
Call RenameFunction(strDir & "\" & fol.Name, lngLevel + 1)
Next
End If
End Sub
'========================================================
' ファイル名と拡張子を分ける処理
'========================================================
Public Sub SplitNameAndExt(ByVal fileNameAndExt As String, ByRef getFileName As String, ByRef getFileExt As String)
Dim regEx As Object
Dim Matches As Object
Dim Match As Object
Dim RE As Object
Dim targetString As String
Set RE = CreateObject("VBScript.RegExp")
With RE
.Pattern = "(.*)\.(xls)"
.ignorecase = True
.Global = True
End With
targetString = fileNameAndExt
Set Matches = RE.Execute(targetString)
For Each Match In Matches
'--------------------------------------------------------
' 処理をOSへ戻す
' 処理時間が長くなるが、大量ファイル処理時の固まり防止
'--------------------------------------------------------
DoEvents
getFileName = Match.submatches(0)
getFileExt = Match.submatches(1)
Next
End Sub
'========================================================
' 処理ファイルのインクリ
'========================================================
Private Sub incrementFileCnt()
M_FileCnt = M_FileCnt + 1
End Sub
'========================================================
' ログ関係
'========================================================
Private Sub LoggerOpen()
M_LogFileNo = FreeFile()
Open ThisWorkbook.Path & "\" & M_LOGFILENAME For Append As M_LogFileNo
End Sub
' ログ閉じる
Private Sub LoggerClose()
Close #M_LogFileNo
End Sub
' ログ出力
Public Sub LoggerOut(ByVal text As String)
Dim strYear As String
Dim strMonth As String
Dim strDay As String
Dim strHour As String
Dim strMin As String
Dim strSec As String
strYear = Format(Year(Date), "00")
strMonth = Format(Month(Date), "00")
strDay = Format(Day(Date), "00")
strHour = Format(Hour(Date), "00")
strMin = Format(Minute(Date), "00")
strSec = Format(Second(Date), "00")
Print #M_LogFileNo, "[" & strYear & "/" & strMonth & "/" & strDay & Space(1) & strHour & ":" & strMin & ":" & strSec & "]" & text
End Sub
ダウンロードできるようにしておきますが、完全自己責任でお使いください
数回使っただけでテストしたワケでもありませんので、動作は保証できません
VBAのソースをよく読んだ上で、お使いください
広告
さいごに、
今回のVBAプログラムは、Excel VBAの入門に合うと思います
再帰に不慣れな方には分かりづらいかも知れませんけど・・・
Excel VBAを勉強しようと思っている人、勉強し始めの方は是非参考がてらにお読みください。
Excel VBAのプログラミング のレッスンに興味がある方、レッスン内容を聞いてみたい方、なんなりとお問い合わせください。
無料体験レッスンもありますのでお気軽にどうぞ！！！
