| |
こんにちは。
もうほとんど解決のようなんですが、
Dir関数で書いてみましたので、何かの参考になれば。
Option Explicit
Sub sample()
Dim i As Long, n As Long
Dim FoundFiles As Variant
Dim WB As Workbook, WS As Worksheet
n = RecDir("d:\", "*表.xls", FoundFiles)
For i = 1 To n
Set WB = Workbooks.Open(FoundFiles(i), ReadOnly:=True)
If SheetExist(WB, "ver5.0", WS) Then
MsgBox WB.Name & "に" & WS.Name & "がみつかりました"
ElseIf SheetExist(WB, "Ver5.0", WS) Then
MsgBox WB.Name & "に" & WS.Name & "がみつかりました"
End If
With WS
'ワークシートに対する処理
End With
WB.Close SaveChanges:=False
Next
End Sub
Function SheetExist(WB As Workbook, ShName As Variant, Sh As Worksheet) As Boolean
On Error GoTo Not_Exist
Set Sh = WB.Worksheets(ShName)
SheetExist = True
Exit Function
Not_Exist:
SheetExist = False: Set Sh = Nothing
End Function
Function RecDir(ByVal Path As String, ByVal FileFilter As String, ByRef FoundFiles As Variant) As Long
Dim FileNames() As String, Folders() As String
Dim nFile As Long, nFolder As Long
Dim ret As Variant, i As Long, j As Long, n As Long
nFile = 0: nFolder = 0
Path = IIf(Right(Path, 1) = "\", Path, Path & "\")
ret = Dir(Path & FileFilter, vbNormal)
Do While ret <> ""
If Path <> "." And Path <> ".." Then
If (GetAttr(Path & ret) And vbNormal) = vbNormal Then
nFile = nFile + 1
ReDim Preserve FileNames(1 To nFile)
FileNames(nFile) = Path & ret
End If
End If
ret = Dir
Loop
ret = Dir(Path, vbDirectory)
Do While ret <> ""
If ret <> "." And ret <> ".." Then
If (GetAttr(Path & ret) And vbDirectory) = vbDirectory Then
nFolder = nFolder + 1
ReDim Preserve Folders(1 To nFolder)
Folders(nFolder) = Path & ret
End If
End If
ret = Dir
Loop
For i = 1 To nFolder
n = RecDir(Folders(i), FileFilter, ret)
If n > 0 Then
ReDim Preserve FileNames(1 To nFile + n)
For j = 1 To n
FileNames(nFile + j) = ret(j)
Next
nFile = nFile + n
End If
Next
RecDir = nFile: FoundFiles = FileNames
Erase FileNames, Folders
End Function
|
|
でれすけ
- 05/2/25(金) 10:31 -
