| |
かみちゃんさんと同じ様な物ですが？
「Private Function GetFilesList」が指定フォルダの
「yymmdd.txt」形式のファイル名を配列で返してきます
Option Explicit
Public Sub Sample()
Dim i As Long
Dim rngResult As Range
Dim vntFileNames As Variant
Dim strPath As String
Dim vntDate As Variant
Dim strProm As String
'Listの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngResult = ActiveSheet.Cells(3, "B")
vntDate = rngResult.Value
'フォルダ名を指定
strPath = "C:\list"
'読み込むファイル名を取得(指定フォルダから取得）
If Not GetFilesList(vntFileNames, strPath, vntDate) Then
GoTo Wayout
End If
For i = 1 To UBound(vntFileNames, 1)
rngResult.Offset(i + 4).Value = vntFileNames(i)
Next i
strProm = "処理が完了しました"
Wayout:
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetFilesList(vntFileNames As Variant, _
strFilePath As String, _
vntMark As Variant) As Boolean
Dim i As Long
Dim vntRead() As Variant
Dim strName As String
Dim objFso As Object
Dim lngPos As Long
Dim vntStart As Variant
Dim vntFinish As Variant
Dim lngCount As Long
vntMark = Trim(vntMark)
lngPos = InStr(1, vntMark, "〜", vbBinaryCompare)
If lngPos = 0 Then
GoTo Wayout
End If
'開始日付の取得
vntStart = Left(vntMark, lngPos - 1)
If IsDate(vntStart) Then
vntStart = DateValue(vntStart)
Else
GoTo Wayout
End If
'終了日付の取得
vntFinish = Mid(vntMark, lngPos + 1)
If IsDate(vntFinish) Then
vntFinish = DateValue(vntFinish)
vntFinish = DateSerial(Year(vntFinish), _
Month(vntFinish) + 1, 0)
Else
GoTo Wayout
End If
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'フォルダの存在確認
If Not objFso.FolderExists(strFilePath) Then
GoTo Wayout
End If
'ファイルの存在確認
For i = vntStart To vntFinish
strName = strFilePath & "\" & Format(i, "yymmdd") & ".txt"
If objFso.FileExists(strName) Then
lngCount = lngCount + 1
ReDim Preserve vntRead(1 To lngCount)
vntRead(lngCount) = strName
End If
Next i
'ファイルの数が0でなければ
If lngCount > 0 Then
vntFileNames = vntRead
GetFilesList = True
End If
Wayout:
'フォルダオブジェクトを破棄
Set objFso = Nothing
End Function
|
|
Hirofumi
- 06/1/3(火) 19:52 -
