如何在VBA的For Each循环中正确使用FindNext方法？

核心问题是你每次调用Range("A:A").Find(...)都会从头开始查找第一个"Photo1"，导致所有图片都插入到同一个位置。需要把查找逻辑改成遍历每个CG Code对应的Photo1，用Find和FindNext配合，实现一一对应插入。

修改后的完整代码 #

Private Sub cmdInsertPhoto1_Click()
'insert the photo1 from the folder into each worksheet
Dim ws As Worksheet
Dim fso As FileSystemObject
Dim folder As folder
Dim rngCG As Range, cellCG As Range
Dim rngPhoto As Range, firstPhoto As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture

Application.ScreenUpdating = False

'delete the two sheets if they still exist
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "PDFPrint" Then
        Application.DisplayAlerts = False
        Sheets("PDFPrint").Delete
        Application.DisplayAlerts = True
    End If
Next

For Each ws In ActiveWorkbook.Worksheets
    If ws.Name = "DataSheet" Then
        Application.DisplayAlerts = False
        Sheets("DataSheet").Delete
        Application.DisplayAlerts = True
    End If
Next

Set fso = New FileSystemObject
Set folder = fso.GetFolder(ActiveWorkbook.Path & "\Photos1\")
  
'Loop through all worksheets
For Each ws In ThisWorkbook.Worksheets
    ' 查找当前工作表中所有的CG Code
    Set rngCG = ws.Range("A:A")
    Set cellCG = rngCG.Find(what:="CG Code", MatchCase:=True)
    
    If Not cellCG Is Nothing Then
        ' 查找第一个Photo1，记录初始位置防止循环
        Set rngPhoto = ws.Range("A:A").Find(what:="Photo1", MatchCase:=True)
        Set firstPhoto = rngPhoto
        
        Do
            ' 获取当前CG Code对应的文件名
            strFile = cellCG.Offset(0, 1).Value
            imgFile = strFile & ".png"
            localFilename = folder & "\" & imgFile
            
            ' 检查文件是否存在，避免报错
            If fso.FileExists(localFilename) Then
                ' 设置Photo1相邻单元格的行高
                rngPhoto.Offset(0, 1).EntireRow.RowHeight = 200
                
                ' 插入图片并调整位置
                Set pic = ws.Pictures.Insert(localFilename)
                With pic
                    .ShapeRange.LockAspectRatio = msoFalse
                    .ShapeRange.Width = 200
                    .ShapeRange.Height = rngPhoto.Offset(0, 1).MergeArea.Height
                    .ShapeRange.Top = rngPhoto.Offset(0, 1).MergeArea.Top
                    .ShapeRange.Left = rngPhoto.Offset(0, 1).MergeArea.Left
                    .Placement = xlMoveAndSize
                End With
            End If
            
            ' 查找下一个CG Code和下一个Photo1
            Set cellCG = rngCG.FindNext(cellCG)
            Set rngPhoto = ws.Range("A:A").FindNext(rngPhoto)
            
            ' 回到初始位置时退出循环，避免无限遍历
        Loop While Not cellCG Is Nothing And cellCG.Address <> rngCG.Find(what:="CG Code", MatchCase:=True).Address _
                And Not rngPhoto Is Nothing And rngPhoto.Address <> firstPhoto.Address
    End If
Next ws

Application.ScreenUpdating = True

' 提示用户完成
MsgBox ("图片插入完成")
End Sub

关键修改点说明 #

• 配对遍历逻辑：用Find+FindNext分别遍历所有"CG Code"和"Photo1"，保证每一组代码对应一个图片插入位置
• 防止无限循环：记录第一个Photo1的位置，当FindNext回到初始位置时退出循环
• 增加错误防护：检查图片文件是否存在，避免找不到文件时触发运行错误
• 优化性能与稳定性：关闭界面刷新减少闪烁，移除不必要的Select操作，直接通过Range对象操作更可靠

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