Dir関数を複数同時実行してはいけない
前回「フォルダ内のファイルを取得する」の時、Dir関数についての注意事項をこう述べた。
注意事項 フォルダ内からファイルを取得するDir関数があるが、Dir関数は入れ子になる（Dir関数実行中に、内部で別のフォルダでDir関数を実行する）と戻り値が被るのであまり使用しない方が良い
その詳細な説明を行う。
一般的なDir関数の使い方
上記のようなフォルダのファイルを一つ一つ取りに行く
実行後、イミディエイトウインドにファイル名が表示される
このような単体の使用ならば問題はないが、DirのLoopを行っている間、別のDirのLoopを実行すると、参照先フォルダが意図しないフォルダに変わってしまう場合がある。
Dir関数を入れ子にして使用した場合
二つのフォルダを参照する
1つ目
２つ目
実行
- ①でstrFileName1 : 1_Test.csvが格納
- ②のIfでFlaseになるので、
- ③に飛んで、strFileName1 : 1_Test2.csvが格納
- また②のIfに戻り、今度はTrueになるので、
- ④でstrFileName2：2_Test.csvが格納
- ⑤のIfでFalseになり
- ⑦でstrFileName2：2_Test2.csvが格納
- また⑤のIfに戻り、今度はTrueになるので
- ⑥でひとつLoopをぬけ、③に戻る
- この③のDirでstrFileName1 : 2_Test3.csvが格納
本来なら①のDirと同じフォルダ（"D:\Macro\テスト領域1\*.*"）を見に行ってほしいのだが、直前の⑦のDirのフォルダ("D:\Macro\テスト領域2\*.*")を見に行ってしまう
この現象は④～⑦を別関数として作成し、内部で呼び出しても同様なので（この方が入れ子になっていることが分かりづらい）、フォルダのファイルを取得する際は、Dir()でなくFileSystemObjectを使用するようが望ましい。
FileSystemObjectによるフォルダ内のファイル取得はこちら↓
フォルダ内のファイルを取得する
前提条件
- マクロ実行ブックが格納されているフォルダの、ファイルを全て取得
注意事項
フォルダ内からファイルを取得するDir関数があるが、Dir関数は入れ子になる（Dir関数実行中に、内部で別のフォルダでDir関数を実行する）と戻り値が被るのであまり使用しない方が良い
Sub GetFileInFolder()
'----FileSystemObjectを使用する
'----参照設定：Microsoft Scripting Runtimeのチェックを忘れずに
Dim objFSO As New FileSystemObject
Dim objFolder As Folder
Dim objFile As File
'該当フォルダをセット
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path) '※ここではマクロ実行ファイル格納フォルダ。必要に応じて任意のパスを指定する
'フォルダ内のファイル分、処理を繰り返す
For Each objFile In objFolder.Files
With objFile
'各ファイルに対する処理をここで行う
End With
Next
End Sub
複数の置換を一度に処理
複数の置換を一度に処理する
前提条件
- A列のデータを、C、D列のデータ通りに置換する（共に実データは2行目から）
- A列、C,D列共に、行数に制限はないものとする
仕様
- 列は固定だが、定数としてソース上で定義する
- C,D列の語句一つ一つを、Range.Replaceを使用してA列一括置換
VBAコード
Sub ReplaceWord()
'各列を定義
Const lngTargetCol As Long = 1 '置換対象列
Const lngBeforeWordCol As Long = 3 '置換前列
Const lngAfterWordCol As Long = 4 '置換後列
Const lngTargetStartRow As Long = 2 '置換対象列の実データ開始行
Const lngBeforeWordStartRow As Long = 2 '置換前列の実データ開始行
Dim lngTargetMaxRow As Long
Dim lngBeforeWordMaxRow As Long
Dim i As Integer
'各列の最終行を取得
lngTargetMaxRow = lngGetMaxRow(ActiveSheet, lngTargetCol) '置換対象列の実データ最終行
lngBeforeWordMaxRow = lngGetMaxRow(ActiveSheet, lngBeforeWordCol) '置換前列の実データ最終行
'置換語句の数（置換前列の実データ数）だけ置換処理を繰り返す
For i = lngBeforeWordStartRow To lngBeforeWordMaxRow
'【Range.Replace】を使用
'構文：Range（【置換対象データ範囲】）.replace(【検索前語句】、【検索後語句】）
Call Range(Cells(lngTargetStartRow, lngTargetCol), Cells(lngTargetMaxRow, lngTargetCol)).Replace(Cells(i, lngBeforeWordCol).Value, Cells(i, lngAfterWordCol).Value)
Next i
End Sub
呼び出し関数
'------------------------------------------------------
'表内最大行を取得
'
' 戻値：表内最大行
'
' 引数：対象ワークシート
' ：カウント基準となる列（省略時：1（A列））
'
' 注意：オートフィルター、非表示は解除してから行うこと
'-------------------------------------------------------
Function lngGetMaxRow(wsWorksheet As Worksheet, Optional lngCountBaseCol As Long = 1) As Long
Dim lngMaxRow As Long
lngMaxRow = wsWorksheet.Cells(Rows.Count, lngCountBaseCol).End(xlUp).Row 'シート最大行からCtrl+↑で表内最大行取得
lngGetMaxRow = lngMaxRow
End Function
実行後 ↓
Dialogでフォルダを指定
読み込む、または保存などで、任意のフォルダを指定する
前提条件
- Dialogを表示し、フォルダを指定する
- Dialog上でキャンセルボタンを押下した場合は、処理を行わない
- 初期表示DialogはActiveWorkBookのフォルダか否か選べる
仕様
- 初期表示Dialogに指定するフォルダがある場合は引数に持たせる。持たせない場合はActiveWorkBookのフォルダになる
- キャンセル押下時は返値（選択フォルダパス）が空欄（””）
'------------------------------------------------------
'Dialogを表示し任意のフォルダを取得
'
' 戻値：選択フォルダパス
'
' 引数：アクティブブックフォルダフラグ（省略時False）
'-------------------------------------------------------
Function GetFolderUseDialog(Optional strInitPath As String = "") As String
Dim strSelecedtFolder As String '取得フォルダ名
strSelecedtFolder = ""
'msoFileDialogFolderPickerを使用
With Application.FileDialog(msoFileDialogFolderPicker)
'もし引数がない場合、アクティブワークブックが格納されているフォルダDialogが初期表示される
'引数がある場合、そのフォルダを初期表示する
If strInitPath = "" Then
.InitialFileName = ActiveWorkbook.Path
Else
.InitialFileName = strInitPath
End If
'Dialogが表示され、OKを押下したら値を返す
If .Show = True Then
strSelecedtFolder = .SelectedItems(1)
End If
End With
GetFolderUseDialog = strSelecedtFolder
End Function
呼び出し方
Sub test()
Dim strFileName As String
strFileName = ""
strFileName = GetFolderUseDialog("C:\temp") '初期表示Dialogを指定
【または】
strFileName = GetFolderUseDialog() '初期表示Dialogを未指定=ActiveWorkBookのフォルダが表示
If strFileName = "" Then
'未選択時の処理
Else
'選択時の処理
End If
End Sub
初期表示Dialogを指定した場合 C:\tempが初期表示
初期表示Dialogを指定しなかった場合 ActiveWorkBookのフォルダが表示
Excelファイルをcsvデータにして保存
前提条件
問題点
以上の点を踏まえた仕様
- 関数はPERSONAL.XLSB上に作成し、どのExcelファイルからも汎用的に呼び出せるようにする
- 元のExcelファイルとは別領域に保存用ファイルを作成し、そのファイルをcsvファイルとして保存することで、元データはそのまま存在し続けるようにする
Sub SaveCopyCSV()
'----FileSystemObjectを使用する
'----参照設定：Microsoft Scripting Runtimeのチェックを忘れずに
Dim objFSO As New FileSystemObject
'保存対象ActiveBookをobjectに格納
Dim wbTargetBook As Workbook
Set wbTargetBook = ActiveWorkbook
'保存ファイル名
Dim strSaveFile As String
'保存ファイル名 = 現在のフォルダ+現在のファイル名+拡張子csv
strSaveFile = wbTargetBook.Path & "\" & objFSO.GetBaseName(wbTargetBook.Name) & ".csv"
'元ファイルをTmpファイルとしてコピーする（これ以後TmpファイルがActiveWorkBook）
wbTargetBook.ActiveSheet.Copy
'CSVファイルにして保存、csvファイルは保存後閉じる
ActiveWorkbook.SaveAs Filename:=strSaveFile, FileFormat:=xlCSV
ActiveWorkbook.Close
'元ファイルをActiveに戻す
wbTargetBook.Activate
End Sub
下記フォルダ内のTest.xlsxファイル
ファイルの中身
マクロを呼び出す PERSONAL.XLSBのSaveCopyCSV
実行後、同フォルダにcsvファイルが作成されている
内容
実行後、元ファイルはActiveに戻っている
AccessデータをExcelにコピーし「折り返して全体を表示する」を解除
↓ 貼り付け
↓ このままでは見栄えが悪いので、以下の処理を行う
①セルの書式設定で「折り返して全体を表示する」のチェックを外す
②列幅を自動調整
この①、②を実行する関数
Sub AccessToExcelFormat()
'「折り返して全体を表示する」を解除する
Selection.WrapText = False
'列幅を自動調整する
'---EntireColumn => 対象セルが含まれる列を指す
Selection.EntireColumn.AutoFit
End Sub
※Selection = 選択中のセル。Range型
実行後
セルの書式を書き出す
'------------------------------------------------------
'セルの書式設定を書き出し
'
' 戻値：なし
'
' 引数：コピー元セル（範囲指定は不可）
' ：コピー先セル（範囲指定可）
'
' 注意：コピー元セルが複数指定されている場合エラーとする
'-------------------------------------------------------
Sub WriteRangeFormat(rngMoto As Range, rngSaki As Range)
If rngMoto.Count > 1 Then
'エラー処理を行う（ログを出す、セルを色づけする等）
Exit Sub
End If
rngSaki.Value = rngMoto.NumberFormatLocal
End Sub
【呼び出し方】
'A1の書式設定をB1に書き出し
Call WriteRangeFormat(ActiveSheet.Range("A1"), ActiveSheet.Range("B1"))
