Copying pictures to several sheets with VBA

skpma

New Member
Joined
Mar 3, 2020
Messages
31
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
Hello everyone

I have the following case:

jpeg files are stored in a folder. The number of files is not fix, but never more than 27. These files are named as followed: 1(1).jpeg, 1(2).jpeg,1(3).jpeg,1(24).jpeg etc.
It is possible that some numbers are missing (for example 1(8).jpeg does not exist). This names are then looked up in a Excel sheet by their corresponding name and if it is a match, the picture gets copied to the sheet at the place where the name was found. The problem is that on sheet 1, we want to have only pictures 1 -9, then pictures 10 - 18 should be on sheet 2 and pictures 19 - 27 should be on sheet 3. If no match is found or there are no more pictures to copy, no picture should be copied and the macro should stop. Below is the code that works for sheet 1 and pictures 1-9. How can I switch to the other worksheets and copy the pictures in the same manner as sheet 1?
Thanks in advance for your advice.

VBA Code:
Sub CopyPictures()
Dim objShape As Object
Dim strPath As String, strFileName As String
Dim strImgName As String


 
strPath = "\\server\pictures\"
strFileName = Dir(strPath & "*.jpeg")


    On Error Resume Next
    
    Do Until Len(strFileName) = 0
        strImgName = Left(strFileName, Len(strFileName) - 5)
        
        Cells.Find(What:=strImgName).Activate
         ActiveCell.Offset(0, 1).Activate
    
        Set objShape = ActiveSheet.Shapes.AddPicture( _
                        Filename:=strPath & strFileName, _
                        LinkToFile:=False, _
                        SaveWithDocument:=True, _
                        Left:=ActiveCell.Left, _
                        Top:=ActiveCell.Top, _
                        Width:=0, _
                        Height:=0)
        
        With objShape
            .LockAspectRatio = msoTrue
            .Height = 220
            .Left = .Left + 10
            .Top = .Top + 10

  End With
        
        strFileName = Dir()
  
    Loop

End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Try this

VBA Code:
Sub CopyPictures()
  Dim sh As Worksheet, f As Range
  Dim sPath As String, sName As String, sImg As String
  
  sPath = "\\server\pictures\"
  sName = Dir(sPath & "*.jpeg")
  
  Do Until Len(sName) = 0
    sImg = Left(sName, Len(sName) - 5)
    For Each sh In Sheets
      Set f = sh.Cells.Find(sImg, , xlValues, xlWhole)
      If Not f Is Nothing Then
        With sh.Shapes.AddPicture(sPath & sName, False, True, f.Offset(, 1).Left, f.Offset(, 1).Top, 0, 0)
          .LockAspectRatio = msoTrue
          .Height = 220
          .Left = .Left + 10
          .Top = .Top + 10
        End With
        Exit For
      End If
    Next sh
    sName = Dir()
  Loop
End Sub
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,517
Messages
6,114,085
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top