Excel VBAのFileSearch機能

質問

初めて投稿します。助けてください。
以下のVBAを使用して業務を行っているのですが
このマクロが動かなくなってしまいました。
ネット等で調べてわかったのですが
XP問題で社内PCがすべて変わりExcelも２０１３になってしまい
２０１３では、下記に記載されているFileSearch機能が使用できないようです。
出来れば下記の分をExcel２０１３でも
動くようにどの部分を変更すればいいいか教えていただけないでしょうか？

---------------------＜VBA文＞-------------------------
Sub 作成()
Dim i, j, no As Integer
Dim Mpath, Mname, Mfull As String

Mpath = ActiveWorkbook.Path
Mname = ActiveWorkbook.Name
Mfull = Mpath & "\" & Mname
Worksheets("一覧").Select
Range("A2:A200").Clear
With Application.FileSearch
.NewSearch
.LookIn = Mpath
.Filename = "*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .Execute
If .FoundFiles(i) <> Mfull Then
Cells(i + 1, 1).Value = .FoundFiles(i)

j = Len(Cells(i + 1, 1))
If j > 218 Then
MsgBox ("218文字を超えてます。")
Exit Sub
End If

End If
Next i
Else
MsgBox ("見つかりませんでした。")
End If
End With
　 Range("A2").Select
Range("A2:A1000").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal

End Sub

回答No.1

t-aka · ベストアンサー

例えば、こんな感じでいかがでしょうか。

----------
Sub 作成()

Dim i As Integer, j As Integer, no As Integer
Dim Mpath As String, Mname As String, Mfull As String

Mpath = ActiveWorkbook.Path
Mname = ActiveWorkbook.Name
Mfull = Mpath & "\" & Mname
Worksheets("一覧").Select
Range("A2:A200").Clear

Dim result() As String
Call search(Mpath, result())

If UBound(result) > 0 Then
For i = 0 To UBound(result)
If result(i) <> Mfull Then
Cells(i + 1, 1).Value = result(i)

j = Len(Cells(i + 1, 1))
If j > 218 Then
MsgBox ("218文字を超えてます。")
Exit Sub
End If

End If
Next i
Else
MsgBox ("見つかりませんでした。")
End If

Range("A2").Select
Range("A2:A1000").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, DataOption1:=xlSortNormal

End Sub

Sub search(Mpath As String, result() As String)

Dim arrayFilePath As String
arrayFilePath = Dir(Mpath & "*.xls")

Dim i As Integer
i = 0
ReDim result(i)

Do Until arrayFilePath = ""
ReDim Preserve result(i)
result(i) = Mpath & arrayFilePath

i = i + 1
arrayFilePath = Dir()
Loop

End Sub