如何让Excel根据单元格项目编号自动提取对应项目文件夹的项目名称？

完全可以实现这个需求，不用硬编码项目列表，直接从指定父文件夹中搜索匹配的子文件夹并提取名称。下面提供两种实用方案：

方案一：自定义函数（UDF） #

通过编写VBA自定义函数，在单元格中直接调用即可自动提取项目名称：

1. 打开你的Excel工作簿，按Alt+F11打开VBA编辑器
2. 右键点击左侧工程窗口中的工作簿名称，选择「插入」→「模块」
3. 将以下代码粘贴到模块中：

Function GetProjectName(projectID As String, parentFolderPath As String) As String
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 检查父文件夹是否存在
    If Not fso.FolderExists(parentFolderPath) Then
        GetProjectName = "文件夹路径无效"
        Exit Function
    End If
    
    Set folder = fso.GetFolder(parentFolderPath)
    
    ' 遍历所有子文件夹
    For Each subFolder In folder.SubFolders
        ' 判断文件夹名称是否以目标项目编号开头
        If InStr(1, subFolder.Name, projectID, vbTextCompare) = 1 Then
            ' 提取编号后的项目名称（假设编号和名称之间有空格分隔）
            GetProjectName = Mid(subFolder.Name, Len(projectID) + 2)
            Exit Function
        End If
    Next subFolder
    
    ' 未找到匹配文件夹时返回提示
    GetProjectName = "未找到对应项目"
End Function

4. 返回工作表，在B2单元格输入公式（替换为你的实际父文件夹路径）：
   =GetProjectName(A2, "D:\Projects\ParentFolder")
5. 下拉公式应用到其他行即可

方案二：工作表自动触发事件 #

如果希望输入项目编号后自动填充，无需手动输入公式，可以使用工作表Change事件：

1. 打开VBA编辑器，双击左侧工程窗口中目标工作表的名称（比如「Sheet1」）
2. 将以下代码粘贴到代码窗口：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim parentFolderPath As String
    Dim projectID As String
    
    ' 设置父文件夹路径
    parentFolderPath = "D:\Projects\ParentFolder"
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 仅处理A列的单元格变化
    If Target.Column = 1 And Target.Cells.Count = 1 Then
        projectID = Target.Value
        If projectID = "" Then
            Target.Offset(0, 1).Value = ""
            Exit Sub
        End If
        
        ' 检查父文件夹是否存在
        If Not fso.FolderExists(parentFolderPath) Then
            Target.Offset(0, 1).Value = "文件夹路径无效"
            Exit Sub
        End If
        
        Set folder = fso.GetFolder(parentFolderPath)
        
        ' 遍历子文件夹查找匹配项
        For Each subFolder In folder.SubFolders
            If InStr(1, subFolder.Name, projectID, vbTextCompare) = 1 Then
                Target.Offset(0, 1).Value = Mid(subFolder.Name, Len(projectID) + 2)
                Exit Sub
            End If
        Next subFolder
        
        Target.Offset(0, 1).Value = "未找到对应项目"
    End If
End Sub

3. 保存工作簿为「启用宏的工作簿（*.xlsm）」格式，之后在A列输入项目编号，B列会自动填充对应的项目名称

注意事项 #

• 确保启用宏：打开工作簿时如果弹出宏安全提示，选择「启用内容」
• 路径要准确：代码中的父文件夹路径需替换为你实际的硬盘路径，注意路径分隔符用反斜杠\
• 重复编号处理：如果存在多个子文件夹以同一编号开头，代码会返回第一个匹配的项目名称，可根据需求修改逻辑

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