Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

48300 / 76732

←次へ　｜　前へ→


	【33368】Re:ファイルを開く

Hirofumi - 06/1/9(月) 20:11 -


	引用なし

	パスワード

こんなのも有るよ？

Option Explicit

Public Sub Sample()

　　Dim i As Long
　　Dim rngResult As Range
　　Dim vntFileNames As Variant
　　Dim strPath As String
　　Dim strCompe As String
　　Dim strProm As String
　　
　　'フォルダ名を指定
　　strPath = "E:\Office2000\Excel\Test5"
　　strPath = ThisWorkbook.Path

　　'読み込むファイル名を取得(指定フォルダから取得）
　　strCompe = "^test_[0-9][0-9][01][0-9][0-3][0-9]$"
　　If Not GetFilesList(vntFileNames, strPath, strCompe, "xls") Then
　　　　GoTo Wayout
　　End If
　　　　
　　'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
　　Set rngResult = ActiveSheet.Cells(1, "A")

　　For i = 1 To UBound(vntFileNames, 1)
　　　　rngResult.Offset(i).Value = vntFileNames(i)
　　Next i
　　
　　strProm = "処理が完了しました"
　　
Wayout:
　　
　　Set rngResult = Nothing
　　
　　MsgBox strProm, vbInformation
　　
End Sub

Public Function GetFilesList(vntFileNames As Variant, _
　　　　　　　　　　　　　　strFilePath As String, _
　　　　　　　　　　　　　　Optional strNamePattan As String = ".*", _
　　　　　　　　　　　　　　Optional strExtePattan As String = ".*") As Boolean

　　Dim i As Long
　　Dim objFiles As Object
　　Dim objFile As Object
　　Dim regExten As Object
　　Dim regName As Object
　　Dim vntRead() As Variant
　　Dim strName As String
　　Dim objFso As Object

　　'FSOのオブジェクトを取得
　　Set objFso = CreateObject("Scripting.FileSystemObject")
　
　　'フォルダの存在確認
　　If Not objFso.FolderExists(strFilePath) Then
　　　　GoTo Wayout
　　End If

　　'regExtenpのオブジェクトを取得（正規表現を作成）
　　Set regExten = CreateObject("VBScript.RegExp")
　　With regExten
　　　　'パターンを設定
　　　　.Pattern = strExtePattan
　　　　'大文字と小文字を区別しないように設定
　　　　.IgnoreCase = True
　　End With
　　Set regName = CreateObject("VBScript.RegExp")
　　With regName
　　　　'パターンを設定
　　　　.Pattern = strNamePattan
　　　　'大文字と小文字を区別しないように設定
　　　　.IgnoreCase = True
　　End With

　　'フォルダオブジェクトを取得
　　Set objFiles = objFso.GetFolder(strFilePath).Files

　　'ファイルの数が0でなければ
　　If objFiles.Count <> 0 Then
　　　　For Each objFile In objFiles
　　　　　　With objFile
　　　　　　　　strName = .Name
　　　　　　　　'検索をテスト
　　　　　　　　If regExten.test(objFso.GetExtensionName(strName)) Then
　　　　　　　　　　If regName.test(objFso.GetBaseName(strName)) Then
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　　　ReDim Preserve vntRead(1 To i)
　　　　　　　　　　　　vntRead(i) = strName
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　Next objFile
　　End If

　　Set regExten = Nothing
　　Set regName = Nothing

　　If i <> 0 Then
　　　　ReDim vntFileNames(1 To UBound(vntRead))
　　　　For i = 1 To UBound(vntRead)
　　　　　　vntFileNames(i) _
　　　　　　　　= StrConv(strFilePath & "\" & vntRead(i), vbNarrow)
　　　　Next i
　　　　GetFilesList = True
　　End If

Wayout:

　　'フォルダオブジェクトを破棄
　　Set objFiles = Nothing
　　Set objFile = Nothing
　　Set objFso = Nothing

End Function

1 hits

▼

【33333】ファイルを開く mame 06/1/9(月) 15:04