VBA实现从任意文件夹抓取指定类型文件名至Excel单元格并去重

Hey there! 我明白你需要的是一个能灵活适配任意文件夹、抓取指定类型文件名、自动去重后按行写入Excel单元格的VBA工具，刚好可以基于你提到的VBA Get File Name From Path and Store it to a Cell思路扩展实现。话不多说，直接上完整方案：

核心功能亮点 #

• 支持动态选择任意目标文件夹，不用硬编码固定路径
• 可自定义指定要抓取的文件类型（比如.xlsx、.pdf、.txt）
• 自动检查当前工作簿中已存在的文件名，绝对不会写入重复内容
• 文件名优先按行向下排列（从当前选中单元格开始，逐行向下填充，每个文件名占独立单元格）

完整VBA代码 #

Sub GetUniqueFileNames()
    Dim targetFolder As String
    Dim fileExt As String
    Dim fileName As String
    Dim ws As Worksheet
    Dim currentCell As Range
    Dim usedRange As Range
    Dim isDuplicate As Boolean
    
    ' 设置要抓取的文件类型（可修改，比如改为".pdf"、".txt"）
    fileExt = ".xlsx"
    
    ' 让用户选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要抓取文件名的文件夹"
        If .Show = -1 Then
            targetFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，程序退出", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 设置要写入的工作表和起始单元格（默认使用当前活动工作表和选中单元格）
    Set ws = ActiveSheet
    Set currentCell = ActiveCell
    
    ' 获取工作表已使用的区域（用于重复检查）
    On Error Resume Next
    Set usedRange = ws.UsedRange
    On Error GoTo 0
    
    ' 遍历文件夹中指定类型的文件
    fileName = Dir(targetFolder & "*" & fileExt)
    Do While fileName <> ""
        isDuplicate = False
        
        ' 检查当前文件名是否已存在于工作表中
        If Not usedRange Is Nothing Then
            If WorksheetFunction.CountIf(usedRange, fileName) > 0 Then
                isDuplicate = True
            End If
        End If
        
        ' 如果不是重复项，写入单元格并移动到下一行
        If Not isDuplicate Then
            currentCell.Value = fileName
            Set currentCell = currentCell.Offset(1, 0) ' 向下移动一行
            ' 更新已使用区域（用于后续重复检查）
            Set usedRange = ws.UsedRange
        End If
        
        ' 取下一个文件名
        fileName = Dir
    Loop
    
    MsgBox "文件名抓取完成！共写入 " & (currentCell.Row - ActiveCell.Row) & " 个不重复文件名", vbInformation
End Sub

关键逻辑解析 #

• 动态文件夹选择：借助Application.FileDialog让用户手动选择目标文件夹，完全适配任意本地路径，不用修改代码里的路径参数
• 重复检查机制：通过WorksheetFunction.CountIf遍历工作表已使用区域，判断当前文件名是否已存在，确保写入的都是唯一值
• 按行向下写入：从你选中的单元格开始，每写入一个文件名就自动跳到下一行，保证每个文件名都在独立单元格中
• 自定义文件类型：修改代码开头的fileExt变量即可切换要抓取的文件类型，非常灵活

使用步骤 #

1. 打开Excel，按下Alt + F11打开VBA编辑器
2. 插入新模块：右键点击左侧项目窗口中的工作簿名称 → 选择「插入」→「模块」
3. 将上面的代码粘贴到模块的代码窗口中
4. 根据你的需求修改fileExt = ".xlsx"这一行，比如要抓PDF就改成".pdf"
5. 返回Excel界面，按下Alt + F8，选择GetUniqueFileNames宏并点击「执行」
6. 在弹出的文件夹选择框中选中目标文件夹，点击「确定」即可自动开始抓取去重

内容的提问来源于stack exchange，提问作者Thien An