つらつら Excel VBA

私の備忘録です。

ファイル数を数える

'指定したディレクトリ内のファイル数を数える。
Public Function FileCount(sDir As String) As Integer
    Dim rtnCnt As Integer
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    rtnCnt = FSO.GetFolder(sDir).Files.Count
    Set FSO = Nothing
    FileCount = rtnCnt
End Function

※細かい条件で数えたい場合は他の方法で頑張る。

フォームのモードレス表示

Public Sub UserFormShow()
    Dim frm As UserForm1
    Set frm = New UserForm1
    frm.Show vbModeless 'フォームのモードレス表示
End Sub

※たくさん表示できます。収拾がつかなくならないよう注意。

追記
モーダルとモードレスは混在不可

ユーザーフォームを数える

'指定した名前のユーザーフォームを数える
Function countUserForm(name As String) As Integer
    Dim cnt As Integer
    Dim frm As Object
    cnt = 0
    For Each frm In UserForms
        If UCase(frm.Caption) = UCase(name) Then
            cnt = cnt + 1
        End If
    Next
    countUserForm = cnt
End Function

※UCase  アルファベットの小文字を大文字に変換する。
(LCaseは逆の動作)
文字の大小が区別されるので、どちらかに統一して比較する。

ランダム値の生成

'ランダム値を取得
Function getRandom(i_min As Integer, i_max As Integer) As Integer
   
    Dim temp As Integer
    Dim sa As Integer '差
   
    Randomize '乱数生成ジェネレータ
   
    '引数が逆だった場合は入れ替え。
    If i_max < i_min Then
        temp = i_max
        i_max = i_min
        i_min = temp
    End If
   
    sa = i_max - i_min + 1 '差分を計算
    getRandom = Int(sa * Rnd) + i_min
   
End Function

ディレクトリの再帰検索

'引数1 targetDir 対象ディレクトリパス
'引数2 extenstion 対象ファイルの拡張子を指定(例:*.csv)
'引数3 recursive サブディレクトリの検索(True:行う, False:行わない)

Public Sub FolderSearch(targetDir As String, extension As String, recursive As Boolean)
   
    Dim FSO As Object
    Dim folder As Object, subFolder As Object, file As Object
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set folder = FSO.GetFolder(targetDir)
   
    'ディレクトリ内のサブディレクトリを列挙
    If recursive = True Then
        For Each subFolder In folder.SubFolders
            Call FolderSearch(subFolder.Path, extension, recursive) '再帰呼び出し
        Next subFolder
    End If
   
    'カレントディレクトリ内のファイルを列挙
    For Each file In folder.Files
        '指定拡張子が合致、または無い場合
        If extension = "" Or file.Name Like extension Then
            '好きな処理

        End If
    Next file
   
    '終了処理
    Set folder = Nothing
    Set FSO = Nothing
   
End Sub