多子文件夹XLSM文件批量超链接VBA代码问题排查

现存问题 #

• 将目标列从A改为B后，首个文件的超链接被错误覆盖为第二个文件的路径
• 代码无法实现以下需求：
  • 移除单元格中的.xlsm后缀
  • 将姓氏拆分至B列、名字拆分至C列
  • 批量打开.xlsm文件并提取指定单元格数据匹配姓名

原代码 #

Sub VBA_Loop_Through_all_Files_in_subfolders_Using_FSO_Early_Binding()

'Variable Declaration
Dim oFSO As FileSystemObject, oFolder As Object
Dim oSubFolders As Object, oSFolderFile As Object
Dim sFile As Object, sfolders As Object
Dim Wbook As Workbook
Dim i  As Integer
Dim cell As Range

'Initialize value
i = 12  'orginal i = 1

'Set objects
Set oFSO = New FileSystemObject
Set oFolder = oFSO.GetFolder("C:\Users\jvittur\OneDrive\Desktop\Attendance")
Set oSubFolders = oFolder.SubFolders

'Loop through subfolders
For Each sfolders In oSubFolders
     Sheet1.Range("B" & i) = sfolders.Name 'orginal Sheet1.Range("A" & i) = sfolders.Name
    Set oSFolderFile = sfolders.Files
    
    'Loop through all files in a subfolder
    For Each sFile In oSFolderFile
        Sheet1.Range("B" & i) = sFile.Name 'orginal Sheet1.Range("A" & i) = sFile.Name
              
              With ActiveSheet
    For Each cell In .Range("B12", .Cells(.Rows.Count, "B").End(xlUp)) 'orgnial For Each cell In .Range("A12", .Cells(.Rows.Count, "A").End(xlUp))
        .Hyperlinks.Add Anchor:=cell, Address:=sFile
    Next
End With

Next
    i = i + 1
     

    Next

 Call RemoveExtension(Range("B12:B500")) 'Orginal ("A12:A500"))
'Release the memory
Set oFSO = Nothing
Set oFolder = Nothing
Set oSubFolders = Nothing
Set oSFolderFile = Nothing

End Sub


Sub RemoveExtension(rng As Range)
' Declare your variables
Dim LR As Long
Dim i As Long
Dim str() As String

With rng
  ' Find the last row
  LR = .Cells(.Rows.Count, 1).End(xlUp).Row
  ' Enter loop
  For i = LR To 1 Step -1
     If Not (IsEmpty(.Cells(i))) Then
        ' Extract and split text using "." as a delimiter
        str() = Split(.Cells(i).Value, ".")
        ' Rewrite text in cell from first array variable in str()
        .Cells(i).Value = str(0)
     End If
  Next i
End With
End Sub

问题根源分析 #

1. 超链接覆盖问题：在文件循环内，每次遍历B列所有已填充单元格添加超链接，导致之前单元格的链接被当前sFile路径覆盖，最终所有历史单元格的链接都会变成最后一个文件的路径。
2. 行号递增逻辑错误：子文件夹循环内，先给B&i赋值文件夹名，随后文件循环又覆盖同一单元格为文件名，且仅在子文件夹循环结束后递增i，导致同一子文件夹下的所有文件只会占用一行单元格，且行号更新不及时。
3. 后缀移除逻辑缺陷：使用Split按.拆分文件名时，若文件名包含多个.（如John.Smith.xlsm），会错误提取第一个.前的内容，而非最后一个.前的文件名主体。
4. 缺少姓名拆分与数据提取逻辑：原代码未实现姓名拆分及跨文件数据提取的功能模块。

优化后的代码 #

Sub ProcessAttendanceFiles()
    ' 变量声明
    Dim oFSO As FileSystemObject, oFolder As Object
    Dim oSubFolder As Object, oFile As Object
    Dim targetWs As Worksheet
    Dim currentRow As Integer
    Dim fileNameNoExt As String
    Dim nameParts() As String
    Dim sourceWb As Workbook
    Dim extractRange As String ' 定义要提取的单元格，例如"Sheet1!A1"
    
    ' 初始化参数
    currentRow = 12
    extractRange = "Sheet1!A1" ' 修改为你需要提取的单元格地址
    Set targetWs = ThisWorkbook.Sheets("Sheet1")
    Set oFSO = New FileSystemObject
    Set oFolder = oFSO.GetFolder("C:\Users\jvittur\OneDrive\Desktop\Attendance")
    
    ' 清空目标区域旧数据（可选）
    targetWs.Range("B12:D" & targetWs.Cells(targetWs.Rows.Count, "B").End(xlUp).Row).ClearContents
    targetWs.Hyperlinks.Delete
    
    ' 遍历子文件夹
    For Each oSubFolder In oFolder.SubFolders
        ' 遍历子文件夹内的xlsm文件
        For Each oFile In oSubFolder.Files
            If LCase(oFSO.GetExtensionName(oFile.Name)) = "xlsm" Then
                ' 1. 移除文件后缀
                fileNameNoExt = oFSO.GetBaseName(oFile.Name)
                
                ' 2. 拆分姓名（假设文件名格式为"姓氏 名字"或"姓氏-名字"，可根据实际格式调整）
                ' 这里以空格为分隔符，若为其他分隔符替换为"-"或","等
                nameParts = Split(fileNameNoExt, " ")
                If UBound(nameParts) >= 1 Then
                    targetWs.Range("B" & currentRow).Value = nameParts(0) ' 姓氏
                    targetWs.Range("C" & currentRow).Value = nameParts(1) ' 名字
                Else
                    targetWs.Range("B" & currentRow).Value = fileNameNoExt ' 无法拆分时保留原名
                End If
                
                ' 3. 添加超链接到姓氏单元格
                targetWs.Hyperlinks.Add _
                    Anchor:=targetWs.Range("B" & currentRow), _
                    Address:=oFile.Path, _
                    TextToDisplay:=targetWs.Range("B" & currentRow).Value
                
                ' 4. 打开文件提取指定单元格数据
                On Error Resume Next ' 捕获文件打开错误
                Set sourceWb = Workbooks.Open(oFile.Path, ReadOnly:=True)
                If Err.Number = 0 Then
                    targetWs.Range("D" & currentRow).Value = sourceWb.Range(extractRange).Value
                    sourceWb.Close SaveChanges:=False
                Else
                    targetWs.Range("D" & currentRow).Value = "文件打开失败"
                End If
                On Error GoTo 0
                
                ' 行号递增
                currentRow = currentRow + 1
            End If
        Next oFile
    Next oSubFolder
    
    ' 释放内存
    Set oFSO = Nothing
    Set oFolder = Nothing
    Set targetWs = Nothing
    Set sourceWb = Nothing
    
    MsgBox "处理完成！", vbInformation
End Sub

优化说明 #

1. 超链接逻辑修复：仅给当前行的B列单元格添加超链接，避免覆盖历史单元格的链接。
2. 行号递增修正：每个文件处理完成后立即递增行号，确保每个文件占用独立行。
3. 后缀移除优化：使用FileSystemObject.GetBaseName直接获取无后缀的文件名，避免多.拆分错误。
4. 姓名拆分功能：通过Split按指定分隔符拆分文件名，可根据实际文件名格式调整分隔符（如空格、横杠、逗号等）。
5. 数据提取功能：批量打开目标文件，提取指定单元格数据到D列，开启只读模式避免修改源文件，添加错误捕获处理文件打开失败的情况。
6. 代码简洁性优化：移除冗余循环，统一变量命名，添加必要注释。

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