| |
もう少し丁寧にするなら
抽出条件が複数に成るので、重複したファイル名を抽出しない様に
Option Explicit
Public Sub Test2()
Dim vntF As Variant
Dim objFS As FileSearch
Dim objFSO As FileSystemObject
Dim dteDate As Date
Dim GYO As Long
Dim cntFound As Long
Dim i As Long
Dim vntPath As Variant
Dim vntFileNames As Variant
Dim strList As String
dteDate = DateAdd("m", Cells(3, 2).Value * -1, Date)
vntPath = Trim(Cells(1, 2).Value)
vntFileNames = Trim(Cells(2, 2).Value)
Rows("5:65536").ClearContents
If vntFileNames = "" Then
GoTo Wayout
End If
vntFileNames = Split(vntFileNames, ",")
Set objFS = Application.FileSearch
Set objFSO = New FileSystemObject
GYO = 4
With objFS
strList = vbTab
For i = 0 To UBound(vntFileNames)
.NewSearch
.LookIn = vntPath
.Filename = vntFileNames(i)
.SearchSubFolders = True
If .Execute() <> 0 Then
For Each vntF In .FoundFiles
With objFSO.GetFile(vntF)
If .DateLastModified >= dteDate Then
'ファイル名が重複しなければ
If InStr(1, strList, vbTab & .Name & vbTab, vbTextCompare) = 0 Then
GYO = GYO + 1
Cells(GYO, 1).Value = .Name
Cells(GYO, 2).Value = .DateLastModified
Cells(GYO, 3).Value = _
Left(.Path, Len(.Path) - Len(.Name) - 1)
strList = strList & .Name & vbTab
End If
cntFound = cntFound + 1
End If
End With
Next vntF
End If
Next i
End With
Wayout:
Set objFS = Nothing
Set objFSO = Nothing
End Sub
|
|
Hirofumi
- 08/11/30(日) 8:41 -
