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.
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