Excel VBA：在文件夹和子文件夹中搜索 Excel 中列出的部件号

Question

VBA 初学者，如果代码不好，请见谅。

我想要实现的是在文件夹及其子文件夹中搜索 B 列中列出的部件号的 .dxf 文件，并根据该 .dxf 文件是否存在返回“是”或“否”在该文件夹或其子文件夹中。

我的预期是代码将从 B2 中列出的第一个部件号开始，在文件夹和子文件夹中搜索相关的 .dxf 文件，返回一个值，然后转到下一个，B3 然后 B4 和以此类推，直到零件编号停止。

它的作用是在文件夹中搜索 B 列中列出的所有部件号，返回所有值，然后搜索子文件夹，返回所有值（覆盖以前的结果）等等，直到没有更多子文件夹可供搜索。

我觉得我接近获得我想要的结果，但不确定我哪里出错了。 代码如下：

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String

Sub FindFile()
HostFolder = "C:\Users\Anyone\DXF\"

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

End Sub
Sub DoFolder(Folder)

Dim SubFolder
Dim Row As Integer
Dim Extension As String
Dim Continue As Boolean

For Each SubFolder In Folder.SubFolders
    DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files

Continue = True
Extension = ".DXF"
Row = 2

While Continue
    If Len(Range("B" & CStr(Row)).Value) = 0 Then Exit Sub

    If Len(Dir(Folder.Path & "\" & Range("B" & CStr(Row)).Value & "*" & Extension)) = 0 Then
            Range("F" & CStr(Row)).Value = "No"
        Else
            Range("F" & CStr(Row)).Value = "Yes"
    End If

    Row = Row + 1

Wend
Next
End Sub

Answer 1

我会重新考虑这里的方法。也许尝试一个宏来管理行循环和一个函数来管理文件查找

1. 第一个宏循环遍历Column B 中的所有文件名并在Column C 中找到文件时输出
2. 用于搜索文件夹/子文件夹路径的第二个宏。如果找到文件，则循环结束并返回TRUE。如果找不到文件，则宏运行它的过程并存在 FALSE

请注意，该函数只是演示逻辑。你只需要采取你必须管理文件夹循环的逻辑并在这个函数中实现

---

Sub File_Range()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long

lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row

For i = 2 To lr
    If Not IsEmpty(ws.Range("B" & i)) Then
        ws.Range("C" & i) = File_Exists(Range("B" & i))
    End If
Next i

End Sub

---

Public Function File_Exists(Target As Range) As Boolean

'False until file is found
File_Exists = False

For Each SubFolder In Folder.SubFolders
    If Len(Dir(Folder.Path & "\" & Target.Value & "*" & Extension)) Then
        File_Exists = True
        Exit Function
    End If
Next SubFolder


End Function

Answer 2

检查文件是否存在

基础知识

• 基本上（不准确），以下将在提供的文件夹路径中找到的所需（DXF）文件的所有文件路径写入数组，将它们替换为没有文件扩展名的文件名，并检查值（文件名）源列对数组，最后将所需的结果 (Yes/No) 写入目标列。
• 调整常量部分中的值。
• 只运行checkFiles，其余的都由它调用。

附加功能

• 为了更好地理解流程，在即时窗口 CTRL+G 中，如果取消注释 Debug.Print 部分，您可以监控正在发生的事情。请注意，如果出现错误值，Join 将失败，但您始终可以像为 mData 所做的那样创建一个循环，其中可能（可能）包含错误值。
• 它将允许源数据和目标数据使用不同的工作表。
• If 将允许源数据和目标数据从不同的行开始。

守则

Option Explicit

Sub checkFiles()
    
    Const FolderPath As String = "C:\Users\Anyone\DXF"
    Const FileExt As String = "DXF" ' Not case-sensitive i.e. 'DXF = dxf'
    Const fFound As String = "Yes"
    Const fNotFound As String = "No"
    Const srcName As String = "Sheet1"
    Const srcFirst As String = "B2"
    Const dstName As String = "Sheet1"
    Const dstFirst As String = "F2"
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    Dim rng As Range      ' (Source and Destination) Data Range
    Dim Data As Variant   ' (Source and Destination) Data Array
    Dim fData() As String ' File Data Array
    Dim mData As Variant  ' Match Data Array
    Dim n As Long         ' File Data and (Match) Data Array Elements Counter
    
    ' Write values from Source Range to Data Array.
    Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
    Data = getColumn(rng)
    'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
    
    ' Write file paths to File Data Array.
    fData = getFilePaths(FolderPath, "*." & FileExt)
    'Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
    
    ' Replace file paths with file names without file extension.
    For n = LBound(fData) To UBound(fData)
        fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
    Next n
    'Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
    
    ' Write 'matches' to Match Data Array.
    mData = Application.Match(Data, fData, 0)
    'Debug.Print "Match Data:"
    'For n = 1 To UBound(mData)
    '    Debug.Print mData(n, 1)
    'Next
    
    ' Overwrite values in Data Array with 'matching results'.
    For n = 1 To UBound(Data) ' or 'UBound(mData)'
        If IsNumeric(mData(n, 1)) Then
            Data(n, 1) = fFound
        Else
            Data(n, 1) = fNotFound
        End If
    Next n
    'Debug.Print "Destination Data:" & vbLf _
        & Join(Application.Transpose(Data), vbLf)
    
    ' Write values from Data Array to Destination Range.
    With defineRange(wb.Worksheets(dstName), dstFirst)
        Dim RowOffset As Long: RowOffset = .Row - rng.Row
        Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
        Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
    End With
    rng.Value = Data
    
End Sub

Function defineRange( _
    ws As Worksheet, _
    ByVal RangeAddress As String) _
As Range
    On Error Resume Next
    Set defineRange = ws.Range(RangeAddress)
    On Error GoTo 0
End Function

Function defineColumnRange( _
    FirstCell As Range) _
As Range
    If Not FirstCell Is Nothing Then
        With FirstCell
            Dim rng As Range
            Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
            Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
            If Not rng Is Nothing Then
                Set defineColumnRange = .Resize(rng.Row - .Row + 1)
            End If
        End With
    End If
End Function

Function getColumn( _
    rng As Range) _
As Variant
    If Not rng Is Nothing Then
        If InStr(rng.Address, ":") > 0 Then
            getColumn = rng.Value
        Else
            Dim Data As Variant
            ReDim Data(1 To 1, 1 To 1)
            Data(1, 1) = rng.Value
            getColumn = Data
        End If
    End If
End Function

Function getFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "") _
As Variant
    Dim ExecString As String
    ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
        & FilePattern & """ /b/s"
    getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function

Function FileFromPath( _
    ByVal FilePath As String, _
    Optional ByVal NoExtension As Boolean = False) _
As String
    Dim FileName As String
    FileName = Right(FilePath, _
        Len(FilePath) - InStrRev(FilePath, "\"))
    If NoExtension Then
        FileName = Left(FileName, InStrRev(FileName, ".") - 1)
    End If
    FileFromPath = FileName
End Function