I need to know how to get FindNext working in my code. It finds the photo inserts it into the column where the code matches, however it does not find the next code in the worksheet, so it keeps overwriting the photos in the first find. Where I have put the comment find next photo1 is where it should be going?

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 rng As Range, cell As Range
Dim strFile As String
Dim imgFile As String
Dim localFilename As String
Dim pic As Picture
Dim findit As String
Dim finditfirst As String

Application.ScreenUpdating = True

'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
ws.Select
    
     Set rng = Range("A:A")
    
     For Each cell In rng
      If cell = "CG Code" Then
      'find the next adjacent cell value of CG Code
       strFile = cell.Offset(0, 1).Value 'the cg code value
       imgFile = strFile & ".png" 'the png imgFile name
       localFilename = folder & "\" & imgFile 'the full location
               
       'find Photo1 cell and select the adjacent cell to insert the image
       findit = Range("A:A").Find(what:="Photo1", MatchCase:=True).Offset(0, 1).Select
       ActiveCell.EntireRow.RowHeight = 200 'max row height is 409.5
            
       Set pic = ws.Pictures.Insert(localFilename)
         With pic
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Width = 200
            .ShapeRange.Height = ActiveCell.MergeArea.Height
            .ShapeRange.Top = ActiveCell.MergeArea.Top
            .ShapeRange.Left = ActiveCell.MergeArea.Left
            .Placement = xlMoveAndSize
         End With
         
        'find next photo1
       
        
      End If
        
        'delete photo after insert
        'Kill localFilename
        
     Next cell

Next ws



Application.ScreenUpdating = True

 ' let user know its been completed
 MsgBox ("Worksheets created")
End Sub

CodePudding user response：

Scan column A for both "Photo1" and "CG Code" values to build collections for each. Then iterate the collections to insert the images.

Option Explicit

Private Sub cmdInsertPhoto1_Click()

    Dim wb As Workbook, ws As Worksheet, fso As FileSystemObject
    Dim rng As Range, cell As Range, pic As Picture
    Dim folder As String, imgFile As String
    Dim lastrow As Long, i As Long, n As Long
    
    Dim colImages As Collection, colPhotos As Collection
    Set colImages = New Collection
    Set colPhotos = New Collection
    Set fso = New FileSystemObject
             
    Set wb = ActiveWorkbook
    folder = wb.Path & "\Photos1\"
    
    Application.ScreenUpdating = False
    For Each ws In wb.Sheets
        'delete the two sheets if they still exist
        If ws.Name = "PDFPrint" Or ws.Name = "DataSheet" Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        Else
                  
            ' find images and photos
            lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For Each cell In ws.Range("A1:A" & lastrow)
                If cell = "CG Code" Then
                    imgFile = folder & cell.Offset(0, 1) & ".png"
                    ' check exists
                    If fso.FileExists(imgFile) Then
                         colImages.Add imgFile
                    Else
                         MsgBox imgFile & " not found", vbCritical
                         Exit Sub
                    End If
                ElseIf cell = "Photo1" Then
                    colPhotos.Add "'" & ws.Name & "'!" & cell.Offset(0, 1).Address
                End If
            Next
        End If
    Next
    
    ' copy images to sheets
    For i = 1 To colImages.Count
    
        imgFile = colImages(i)
        If i <= colPhotos.Count Then
            
            Set cell = Range(colPhotos(i))
            cell.RowHeight = 200 'max row height is 409.5
    
            Set pic = cell.Parent.Pictures.Insert(imgFile) ' ws
            With pic.ShapeRange
                .LockAspectRatio = msoFalse
                .Width = 200
                .Height = cell.MergeArea.Height
                .Top = cell.MergeArea.Top
                .Left = cell.MergeArea.Left
                pic.Placement = xlMoveAndSize
            End With
            n = n   1
                              
        Else
            MsgBox "No location for " & imgFile, vbCritical, i
            Exit Sub
        End If
    
    Next
    Application.ScreenUpdating = True
    
    ' let user know its been completed
    MsgBox n & " images inserted ", vbInformation
     
End Sub