| |
別案として
「ファイルを開く」ダイアログを出さずに、
指定フォルダの「07-03-11*.xls」形式のBookを全てOpenする方法？
Option Explicit
Public Sub Sample2()
Dim i As Long
Dim vntDate As Variant
Dim strPath As String
Dim vntFileNames As Variant
Dim strProm As String
strProm = "処理する日付を入力してください。"
Do
vntDate = InputBox(strProm, "日付入力", Date)
If IsDate(vntDate) Then
Exit Do
Else
strProm = "日付が間違っていますので、再度入力してください。"
End If
Loop Until vntDate = ""
'キャンセルボタンが押された時
If vntDate = "" Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'ファイルのBaseNameを作成
vntDate = Format(DateValue(vntDate), "yy-mm-dd") & ".*"
'ダイアログを開くフォルダを指定(最後に￥を付け無い様にする事)
strPath = ThisWorkbook.Path
'フォルダから指定ファイルを探索
If Not GetFilesList(vntFileNames, strPath, CStr(vntDate), "xls") Then
strProm = "指定ファイルが存在しませんのでマクロを終了します"
GoTo Wayout
End If
'画面更新を停止
' Application.ScreenUpdating = False
For i = 1 To UBound(vntFileNames)
MsgBox vntFileNames(i) & "を開きます"
' Workbooks.Open FileName:=vntFileNames(i)
'ここに一連の処理プログラムを挿入する。
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
MsgBox strProm, vbInformation
End Sub
Private 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 = .Path
'検索をテスト
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
vntFileNames = vntRead
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFiles = Nothing
Set objFile = Nothing
Set objFSO = Nothing
End Function
|
|
Hirofumi
- 07/3/12(月) 22:07 -
