工作问题困惑很久了，恳请老师们帮我实现如下功能。

小城大庸

恳请各位老师帮我实现如下功能：1、如果在各级文件夹中存在对应的文件，双击D列文件名称就能打开对应的文件（主要为PDF、xls、xlsx、doc、docx类型文件）；
2、如果各级文件夹中存在与文件名称对应的文件，如文件1、2、3等，则在F列显示“有”，如果各级文件夹中不存在与文件名称对应的文件，如文件111、aaaaa等，则在F列显示为“无”。
因为有几百个文件夹（文件夹中有子文件夹），有成千上万个文件存放在这些文件夹中，本人请几个老师写过VBA，但因为文件和文件夹太多，VBA运行起来很卡，效率不高。只好再次求助于各位老师，看能否有更加有效的解决方法。

zpy2

可以试试在线的文件检索，速度快建议用 everything

一把小刀闯天下

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Dim flag As Boolean, dic

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Len(Target) = 0 Then Exit Sub
  If Not flag Then Call reset
  If dic.Count = 0 Then Exit Sub
  Dim mark, i, t
  mark = Split("pdf xls xlsx doc docx")
  For i = 0 To UBound(mark)
    t = Target & "." & mark(i)
    If dic.exists(t) Then
      Call ShellExecute(0, "Open", dic(t), 0, 0, 0)
      Exit For
    End If
  Next
  If i = UBound(mark) + 1 Then
    Target.Offset(, 1) = "!"
  End If
End Sub

Sub reset()
  test
End Sub

Sub test()
  Dim filename(), n, fso, t, i
  Set dic = CreateObject("scripting.dictionary")
  Set fso = CreateObject("scripting.filesystemobject")
  Call getfilename(fso, filename, n, ThisWorkbook.Path)
  If n = 0 Then Exit Sub
  For i = 1 To UBound(filename)
    t = Split(filename(i), "\")
    dic(LCase(t(UBound(t)))) = filename(i)
  Next
  flag = True
End Sub

Sub getfilename(fso, filename, n, pth)
  Dim spth, t
  If Right(pth, 1) <> "\" Then pth = pth & "\"
    Set spth = fso.getfolder(pth)
    For Each t In spth.Files
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = spth & "\" & t.Name
    Next
    For Each t In spth.subfolders
      Call getfilename(fso, filename, n, t)
    Next
End Sub

蓝桥玄霜

点击打开各类文件http://club.excelhome.net/thread-1419485-1-1.html
请见代码。

wdx223

1. Sub test()
   
2. Dim flst$, data, i&
   
3. With CreateObject("Wscript.Shell")
   
4.     flst = .exec("cmd /c dir /a-d/b/s/n " & ThisWorkbook.Path).StdOut.Readall
   
5. End With
   
6. With CreateObject("VBScript.RegExp")
   
7.     .Global = True
   
8.     .ignoreCase = True
   
9.     data = [D2:D11].Value
   
10.     For i = 1 To UBound(data)
    
11.         .Pattern = "\" & Replace(Replace(Replace(data(i, 1), ".", "\."), "(", "\("), ")", "\)") & "\.(pdf|xls|xlsx|doc|docx)"
    
12.         data(i, 1) = IIf(.test(flst), "有", "无")
    
13.     Next i
    
14. End With
    
15. [f2].Resize(UBound(data), 1) = data
    
16. End Sub

复制代码

小城大庸

wdx223 发表于 2018-9-19 16:32

        data(i, 1) = IIf(.test(flst), "有", "无")
这句的iif是不是写错了？语法错误？

wdx223

小城大庸 发表于 2018-9-19 16:52
data(i, 1) = IIf(.test(flst), "有", "无")
这句的iif是不是写错了？语法错误？

我的电脑上测试，是可以运行的

小城大庸

一把小刀闯天下 发表于 2018-9-19 16:06
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (By ...

64位系统和64位软件显示出错。Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

不知道为什么

小城大庸 发表于 2018-9-19 16:54
64位系统和64位软件显示出错。Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellEx ...

加 ptrsafe

小城大庸

wdx223 发表于 2018-9-19 16:54
我的电脑上测试，是可以运行的

出现如下错误