遍历子文件夹批量插入图片至Excel：首文件正常，后续无响应求助

问题背景 #

主文件夹下包含多个子文件夹，每个子文件夹内有一个Excel文件和多张图片，需求是打开每个子文件夹中的Excel文件，将对应图片插入指定单元格区域。当前代码处理第一个文件正常，但处理第二个文件时会无响应或直接终止，怀疑循环逻辑存在问题。

原代码 #

Sub InsertImagesIntoPhotoLog()
    On Error Resume Next ' Automatically dismiss error messages
    
    Dim mainFolderPath As String
    Dim subfolderPath As String
    Dim imagePath As String
    Dim mergedCells As Variant
    Dim cellRange As Range
    Dim imageIndex As Integer
    
    ' Set the main folder path
    mainFolderPath = "Y:\\Kansas\\130800S\\130882.00_KCMO_2022_Biennials\\Office_Docs\\Reports\\Short Span Inspection_Files\\Caleb's Short Spans\\Sample\\"
    
    ' Define the merged cell addresses
    mergedCells = Array("B10:G26", "I10:P26", "B29:G45", "I29:P45", "B49:G65", "I49:P65", "B68:G84", "I68:P84", "B88:G104", "I88:P104", _
                        "B107:G123", "I107:P123", "B127:G143", "I127:P143", "B146:G162", "I146:P162", "B166:G182", "I166:P182", _
                        "B185:G201", "I185:P201", "B205:G221", "I205:P221", "B224:G240", "I224:P240", "B244:G260", "I244:P260", _
                        "B263:G279", "I263:P279", "B283:G299", "I283:P299", "B302:G318", "I302:P318", "B322:G338", "I322:P338", _
                        "B341:G357", "I341:P357", "B361:G377", "I361:P377", "B380:G396", "I380:P396", "B400:G416", "I400:P416", _
                        "B419:G435", "I419:P435", "B439:G455", "I439:P455", "B458:G474", "I458:P474")
    
    ' Get the first subfolder in the main folder
    subfolderPath = Dir(mainFolderPath & "*", vbDirectory)
    
    ' Loop through each subfolder in the main folder
    Do While subfolderPath <> ""
        ' Check if the subfolder is a folder and not "." or ".."
        If (GetAttr(mainFolderPath & subfolderPath) And vbDirectory) = vbDirectory And subfolderPath <> "." And subfolderPath <> ".." Then
            ' Set the path to the current subfolder
            subfolderPath = mainFolderPath & subfolderPath & "\\"
            
            ' Get the first Excel file in the subfolder
            imagePath = Dir(subfolderPath & "*.xlsm") ' Modify file extension if needed
            
            ' Check if an Excel file exists in the subfolder
            If imagePath <> "" Then
                ' Set the path to the current Excel file
                imagePath = subfolderPath & imagePath
                
                ' Open the workbook
                Dim wb As Workbook
                Set wb = Workbooks.Open(imagePath)
                
                ' Check if the workbook opened successfully
                If Not wb Is Nothing Then
                    ' Set the worksheet where you want to insert the images in the opened workbook
                    Dim photoLog As Worksheet
                    Set photoLog = wb.Worksheets("KCMO_EBIF_22_PhotoLog")
                    
                    ' Count the number of images in the current subfolder
                    Dim imageCount As Integer
                    imageCount = CountImagesInFolder(subfolderPath)
                    
                    ' Check if the number of images matches the number of merged cells
                    If imageCount = UBound(mergedCells) + 1 Then
                        imageIndex = 1
                        
                        ' Loop through each merged cell address
                        For Each mergedCell In mergedCells
                            ' Construct the merged cell range
                            Set cellRange = photoLog.Range(mergedCell)
                            
                            ' Get the image file path
                            Dim imageFilePath As String
                            imageFilePath = GetImageFilePath(subfolderPath, "Image" & imageIndex & ".jpg") ' Modify image file naming convention if needed
                            
                            If Len(Dir(imageFilePath)) > 0 Then
                                ' Insert the image into the current cell
                                InsertImageIntoCell imageFilePath, cellRange, photoLog
                                
                                ' Increment the image index
                                imageIndex = imageIndex + 1
                            End If
                        Next mergedCell
                        
                        ' Save and close the workbook
                        wb.Close SaveChanges:=True
                    End If
                End If
            End If
        End If
        
        ' Get the next subfolder in the main folder
        subfolderPath = Dir
    Loop
    
    Exit Sub ' Skip error handling
End Sub

Sub InsertImageIntoCell(ByVal imagePath As String, ByVal cellRange As Range, ByVal photoLog As Worksheet)
    On Error Resume Next ' Continue execution in case of error
    
    With cellRange
        ' Clear the contents of the cell
        .ClearContents
        .MergeCells = False
        
        ' Center the image in the cell
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        
        ' Insert the image
        Dim picture As Shape
        Set picture = photoLog.Shapes.AddPicture(fileName:=imagePath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                 Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
        
        If Not picture Is Nothing Then
            With picture
                .LockAspectRatio = msoTrue
                .ShapeRange.Height = .TopLeftCell.Height
                .ShapeRange.Width = .TopLeftCell.Width
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
            End With
        End If
    End With
    
    On Error GoTo 0 ' Disable error handling
End Sub

Function CountImagesInFolder(ByVal folderPath As String) As Integer
    ' Count the number of image files in the specified folder
    Dim count As Integer
    count = 0
    
    ' Get the first image file in the folder
    Dim fileName As String
    fileName = Dir(folderPath & "*.jpg") ' Modify file extension if needed
    
    ' Loop through the files and count the image files
    Do Until fileName = ""
        count = count + 1
        fileName = Dir
    Loop
    
    CountImagesInFolder = count
End Function

Function GetImageFilePath(ByVal folderPath As String, ByVal fileName As String) As String
    ' Get the file path of the image in the specified folder with the given file name
    GetImageFilePath = folderPath & fileName
End Function

问题根源分析 #

1. Dir函数状态被破坏：外层遍历子文件夹的Dir，和内部查找Excel文件、统计图片数量时调用的Dir共享同一个状态，导致后续子文件夹无法正确遍历。
2. 错误处理过于宽泛：全局On Error Resume Next会掩盖所有错误，比如Excel文件打开失败、工作表不存在、图片路径错误等问题，导致程序逻辑异常终止。
3. 对象未显式释放：打开的Workbook、Worksheet等对象没有手动释放，可能导致内存泄漏，引发无响应。
4. 界面操作未优化：未禁用Excel屏幕更新，频繁的界面刷新会大幅降低处理速度，甚至导致卡顿。

修复方案 #

1. 改用FileSystemObject遍历文件夹 #

避免Dir函数的状态冲突，使用FileSystemObject更可靠地遍历子文件夹和文件。

2. 优化错误处理 #

移除全局On Error Resume Next，针对关键操作添加局部错误处理，便于排查问题。

3. 显式释放对象 #

处理完每个Excel文件后，手动释放Workbook、Worksheet等对象，并设置为Nothing。

4. 禁用屏幕更新 #

在程序开始时禁用屏幕更新，结束后恢复，提升处理速度。

5. 避免重复调用Dir #

检查文件存在时，改用FileSystemObject的FileExists方法，避免破坏Dir状态。

修改后的完整代码 #

Sub InsertImagesIntoPhotoLog()
    ' 禁用屏幕更新，提升处理速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim mainFolder As Object
    Set mainFolder = fso.GetFolder("Y:\\Kansas\\130800S\\130882.00_KCMO_2022_Biennials\\Office_Docs\\Reports\\Short Span Inspection_Files\\Caleb's Short Spans\\Sample\\")
    
    Dim mergedCells As Variant
    mergedCells = Array("B10:G26", "I10:P26", "B29:G45", "I29:P45", "B49:G65", "I49:P65", "B68:G84", "I68:P84", "B88:G104", "I88:P104", _
                        "B107:G123", "I107:P123", "B127:G143", "I127:P143", "B146:G162", "I146:P162", "B166:G182", "I166:P182", _
                        "B185:G201", "I185:P201", "B205:G221", "I205:P221", "B224:G240", "I224:P240", "B244:G260", "I244:P260", _
                        "B263:G279", "I263:P279", "B283:G299", "I283:P299", "B302:G318", "I302:P318", "B322:G338", "I322:P338", _
                        "B341:G357", "I341:P357", "B361:G377", "I361:P377", "B380:G396", "I380:P396", "B400:G416", "I400:P416", _
                        "B419:G435", "I419:P435", "B439:G455", "I439:P455", "B458:G474", "I458:P474")
    
    Dim subFolder As Object
    For Each subFolder In mainFolder.SubFolders
        Dim xlFile As Object
        Set xlFile = Nothing
        ' 查找子文件夹内的xlsm文件
        For Each file In subFolder.Files
            If LCase(fso.GetExtensionName(file.Name)) = "xlsm" Then
                Set xlFile = file
                Exit For
            End If
        Next file
        
        If Not xlFile Is Nothing Then
            Dim wb As Workbook
            Dim photoLog As Worksheet
            On Error Resume Next
            Set wb = Workbooks.Open(xlFile.Path)
            Set photoLog = wb.Worksheets("KCMO_EBIF_22_PhotoLog")
            On Error GoTo 0
            
            If Not wb Is Nothing And Not photoLog Is Nothing Then
                ' 统计图片数量
                Dim imageCount As Integer
                imageCount = 0
                For Each file In subFolder.Files
                    If LCase(fso.GetExtensionName(file.Name)) = "jpg" Then
                        imageCount = imageCount + 1
                    End If
                Next file
                
                If imageCount = UBound(mergedCells) + 1 Then
                    Dim imageIndex As Integer
                    imageIndex = 1
                    
                    Dim mergedCell As Variant
                    For Each mergedCell In mergedCells
                        Dim cellRange As Range
                        Set cellRange = photoLog.Range(mergedCell)
                        
                        Dim imageFilePath As String
                        imageFilePath = subFolder.Path & "\Image" & imageIndex & ".jpg"
                        
                        If fso.FileExists(imageFilePath) Then
                            InsertImageIntoCell imageFilePath, cellRange, photoLog
                            imageIndex = imageIndex + 1
                        End If
                    Next mergedCell
                    
                    ' 保存并关闭工作簿
                    wb.Close SaveChanges:=True
                    Set wb = Nothing
                    Set photoLog = Nothing
                Else
                    wb.Close SaveChanges:=False
                    Set wb = Nothing
                    Set photoLog = Nothing
                End If
            Else
                If Not wb Is Nothing Then
                    wb.Close SaveChanges:=False
                    Set wb = Nothing
                End If
            End If
        End If
    Next subFolder
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    Set fso = Nothing
    Set mainFolder = Nothing
    Set subFolder = Nothing
End Sub

Sub InsertImageIntoCell(ByVal imagePath As String, ByVal cellRange As Range, ByVal photoLog As Worksheet)
    On Error GoTo Cleanup
    With cellRange
        .ClearContents
        .MergeCells = False
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        
        Dim picture As Shape
        Set picture = photoLog.Shapes.AddPicture(Filename:=imagePath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                                 Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
        
        If Not picture Is Nothing Then
            With picture
                .LockAspectRatio = msoTrue
                .Top = .TopLeftCell.Top
                .Left = .TopLeftCell.Left
                .Height = .TopLeftCell.Height
                .Width = .TopLeftCell.Width
            End With
        End If
    End With
    Exit Sub
    
Cleanup:
    ' 输出错误信息到立即窗口，便于调试
    Debug.Print "插入图片失败: " & imagePath & "，错误号: " & Err.Number & "，描述: " & Err.Description
End Sub

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