VBA サブフォルダのエクセル検索

Sub allSearchRun()
Dim starRow As Long
Dim fileNameList() As String
Dim searchWord As String
Dim folderPath As String
Dim ws As Worksheet
Dim thWB As Workbook
Dim thWS As Worksheet
Dim fileName As String
Dim searchRange As Range
Dim firstFoundCell As Range
Dim foundCell As Range
Dim HiddenMsg As String
Dim filePath As String
Dim StratTime, StopTime As Variant           '// 処理時間計測用
StartTime = Time
starRow = 6
HiddenMsg = ""
Set thWB = ThisWorkbook
Set thWS = thWB.Sheets(1)
folderPath = thWB.Sheets(1).Range("B2").Value
searchWord = thWB.Sheets(1).Cells(3, 2).Value
Dim r As Long
r = 0
Dim tmpList() As String
   tmpList = runDirCMD
    If UBound(tmpList) = 0 Then
         　MsgBox "ファイルがありません"
         　Exit Sub
     End If
For i = LBound(tmpList) To UBound(tmpList)
    If (InStr(tmpList(i), ".xls") > 0) _
            And (InStr(tmpList(i), ".xlsm") = 0) _
            And (InStr(tmpList(i), "~$") = 0) _
            And (InStr(tmpList(i), ".lnk") = 0) Then
        　r = r + 1
    End If
Next i
ReDim fileNameList(LBound(tmpList) To r)
r = 1
For i = LBound(tmpList) To UBound(tmpList)
    If (InStr(tmpList(i), ".xls") > 0) _
            And (InStr(tmpList(i), ".xlsm") = 0) _
            And (InStr(tmpList(i), "~$") = 0) _
            And (InStr(tmpList(i), ".lnk") = 0) Then
        fileNameList(r) = tmpList(i)
  　       r = r + 1
 End If
Next i
Call clearOldRET
thWB.Sheets(2).Cells(1, 1) = "" '異常記録クリア
For i = LBound(fileNameList) To UBound(fileNameList)
    If Trim(fileNameList(i)) <> "" Then
            　fileName = fileNameList(i)
             　Application.DisplayAlerts = False
            　Application.AskToUpdateLinks = False
            　Call StatusBar(i, UBound(fileNameList))
            　thWS.Cells(4, 3) = fileName
            　Dim objExcel, wb As Object
            　Set objExcel = CreateObject("Excel.Application")
            　On Error Resume Next
            　Set wb = objExcel.Workbooks.Open(fileName, UpdateLinks:=0, ReadOnly:=True,Password:=vbNullString) 'パスワード無効の場合は、異常に記録する
            　errDescription = Err.Description
            　errNum = Err.Number
            　On Error GoTo 0
             　If wb Is Nothing Then
                　　MsgBox "エラーです!" & errDescription
                　　GoTo OpenErro
             　End If
            　On Error Resume Next
            　For Each ws In wb.Worksheets  'ワークシートを取得するとき、失敗した場合は
            　On Error GoTo OpenErro
               　 If Not ws Is Nothing Then
                   　 　filePath = Replace(fileName, wb.Name, "")
                  　  　filePath = Left(filePath, Len(filePath) - 1)
                  　  　Set searchRange = ws.UsedRange
                 　　   If Not searchRange Is Nothing Then
                   　　     　If ws.Visible = xlSheetVisible Then
                   　　　         　　HiddenMsg = ""
                   　　     　Else
                     　　　       　　HiddenMsg = "非表示"
                     　　   　End If
           　             Set foundCell = searchRange.Find(what:=searchWord, LookIn:=xlValues, Lookat:=xlPart, MatchCase:=False)
             　           　 If Not foundCell Is Nothing Then
                    　       　 　thWS.Cells(starRow, 3) = foundCell
                    　        　　Call allSetHPLink(thWS, thWS.Cells(starRow, 4), filePath, wb.Name, ws.Name, foundCell.Address, HiddenMsg)
                    　         　　starRow = starRow + 1
                    　         　　Set firstFoundCell = foundCell
                  　　           　If Not firstFoundCell Is Nothing Then
                   　　　             　Do
                  　　　              　 Set foundCell = searchRange.FindNext(foundCell)
                  　　　         　      If Not foundCell Is Nothing Then
                     　　　　           　    If foundCell.Address <> firstFoundCell.Address Then
                     　　　　            　　       　thWS.Cells(starRow, 3) = foundCell
                    　　　　              　　      　Call allSetHPLink(thWS, thWS.Cells(starRow, 4), filePath, wb.Name, ws.Name, foundCell.Address, HiddenMsg)
                      　　　                  　　　　starRow = starRow + 1
                       　　　　             　　End If
                         　　　        　　Else
                          　　          　　　　GoTo findCelNull
                        　　　         　　End If
                           　　      　　　Loop Until foundCell Is Nothing Or foundCell.Address = firstFoundCell.Address
                   　  　　　        End If
                 　 　　       End If
          　      　     End If
                 End If
findCelNull:
            Next ws
            wb.Close saveChanges:=False
            thWS.Cells(4, 3) = ""
            Application.DisplayAlerts = True
            Application.AskToUpdateLinks = True
    End If
OpenErro:
If errDescription <> "" Then '異常記録
　    thWB.Sheets(2).Cells(1, 1) = thWB.Sheets(2).Cells(1, 1) & errDescription & ":" & fileName & " " & Now() & vbCrLf
　    errDescription = ""
End If
thWB.Save
Next i
StopTime = Time - StartTime
thWS.Cells(4, 3) = "所要時間:" & Minute(StopTime) & "分" & Second(StopTime) & "秒" & "" & ""

MsgBox "検索完了"
Application.StatusBar = False
End Sub
'結果のハイバーリングを追加
Sub allSetHPLink(thWS As Worksheet, retCell As Range, folderPath As String, fileName As String, sheetName As String, cellAddress As String, HiddenMsg As String)
    Dim linkAddress
    Dim ws As Worksheet
    Set ws = thWS
    linkAddress = folderPath & "\" & fileName
    retCell = fileName & "$" & sheetName
    If HiddenMsg = "" Then
    　   ws.Hyperlinks.Add Anchor:=retCell, _
     　  Address:=linkAddress, _
    　   SubAddress:=sheetName & "!" & cellAddress, _
    　   TextToDisplay:=fileName & "$" & sheetName & cellAddress
    End If
    
End Sub

'サブフォルダ検索
Function runDirCMD() As String()
Dim cmd As String
Dim output As String
Dim outputArray() As String
Dim i As Long
Dim buf() As Byte

Dim direPath As String
direPath = ThisWorkbook.Sheets(1).Cells(2, 2)
tmpFile = ThisWorkbook.path & "\temp.txt"
strCmd = "dir /a-d /s /b " & direPath & " >" & Chr(34) & tmpFile & Chr(34)
   With CreateObject("Wscript.Shell")
         .Run "cmd /c" & strCmd, 7, True
    End With
If FileLen(tmpFile) < 1 Then
    　   ' MsgBox "該当するファイルがありません"
   　     runDirCMD = Split(StrConv("", vbUnicode), vbCrLf)
   　     Exit Function
End If
Open tmpFile For Binary As #1
        ReDim buf(1 To LOF(1))
        Get #1, , buf
    Close #1
    Kill tmpFile
  outputArray() = Split(StrConv(buf, vbUnicode), vbCrLf)
    runDirCMD = outputArray()
End Function
'進捗表示
Sub StatusBar(curStatus, tatle)
    Dim str As String
    blockCur = Round((curStatus / tatle) * 10)
    leftover = Round((1 - curStatus / tatle) * 10)
    str = Round((curStatus / tatle) * 100) & "% :"
    For i = 0 To blockCur - 1
     str = str & "■"
    Next
    For i = 0 To leftover - 1
     str = str & "□"
    Next
    Application.StatusBar = str
End Sub

Sub clearOldRET()
 Dim ws As Worksheet
 Dim starCell As Range
 Dim dataCell As Range
 Set ws = ActiveSheet
Set starCell = getStartRange("結果：", 0, 1)
Set dataCell = starCell.Resize(ws.Rows.Count - starCell.Row + 1, ws.Columns.Count - starCell.Column + 1)
    dataCell.Clear
End Sub

Sub pathSelect()
Dim folderPath As String
 With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "PATHを選択してください。"
        .AllowMultiSelect = False
            If .Show = -1 Then
                folderPath = .SelectedItems(1)
                
                ThisWorkbook.ActiveSheet.Cells(2, 2) = folderPath
                End If
        End With
        Cancel = True '
End Sub