plz help me. want to insert multiple pictures in merged cells.

[vipin.panchal2008]

Sub CompressMultiplePictures()
Dim fileNames As Variant
Dim pic As Picture
Dim r As Range
Dim cellAddresses As Variant
Dim i As Long

' Define the target cell addresses for inserting pictures
cellAddresses = Array("B5", "D5", "B9", "D9", "B18", "D18", "B22", "D22", "B31", "D31", "B35", "D35", "B44", "D44")

' Prompt the user to select multiple image files
fileNames = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select image files...", MultiSelect:=True)

If IsArray(fileNames) Then
' Loop through each selected file and each cell address
For i = LBound(fileNames) To UBound(fileNames)
' Set the active cell reference (r) to the current cell address
Set r = ActiveSheet.Range(cellAddresses(i))

' Insert the selected image into the "Snaps" worksheet and assign it to the pic variable
Set pic = Worksheets("Snaps").Pictures.Insert(fileNames(i))

With pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = r.Left
.Top = r.Top
.Width = r.Width
.Height = r.Height
End With

' Compress the picture
Application.SendKeys "%a~"
Application.CommandBars.ExecuteMso "PicturesCompress"
Next i
End If
End Sub

 

[Lutfor Rahman Shimanto]

Sub CompressMultiplePictures()
Dim fileNames As Variant
Dim pic As Picture
Dim r As Range
Dim cellAddresses As Variant
Dim i As Long

' Define the target cell addresses for inserting pictures
cellAddresses = Array("B5", "D5", "B9", "D9", "B18", "D18", "B22", "D22", "B31", "D31", "B35", "D35", "B44", "D44")

' Prompt the user to select multiple image files
fileNames = Application.GetOpenFilename( _
FileFilter:="Images (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png", _
Title:="Please select image files...", MultiSelect:=True)

If IsArray(fileNames) Then
' Loop through each selected file and each cell address
For i = LBound(fileNames) To UBound(fileNames)
' Set the active cell reference (r) to the current cell address
Set r = ActiveSheet.Range(cellAddresses(i))

' Insert the selected image into the "Snaps" worksheet and assign it to the pic variable
Set pic = Worksheets("Snaps").Pictures.Insert(fileNames(i))

With pic
.ShapeRange.LockAspectRatio = msoFalse
.Left = r.Left
.Top = r.Top
.Width = r.Width
.Height = r.Height
End With

' Compress the picture
Application.SendKeys "%a~"
Application.CommandBars.ExecuteMso "PicturesCompress"
Next i
End If
End Sub

Hello VipinPanchal2008

You are most welcome to the ExcelDemy Forum. Thanks for reaching out and posting your queries.

You wanted to insert multiple images in merged cells. I am delighted to inform you that I have developed an Excel VBA sub-procedure to reach your goal. Thanks for the code you provided.

Navigate to Developer >> click on Visual Basic.

​

Due to this, the VBA Editor window will appear.

• Hover over Insert and click on Module.
• Insert the following code and Run.

Sub InsertImagesInMergedCells()
    
    Dim cellAddresses As Variant
    Dim cellAddress As Variant
    Dim imgFile As Variant
    Dim pic As Picture
    Dim i As Long
    Dim cell As Range
    Dim mergedWidth As Double
    Dim mergedHeight As Double
    
    cellAddresses = Array("B5", "H5", "B31", "H31")
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Image Files"
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif; *.bmp", 1
        .AllowMultiSelect = True
        
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                cellAddress = cellAddresses(i - 1)
                
                Set cell = ThisWorkbook.Sheets("Sheet1").Range(cellAddress)
                Set pic = cell.Parent.Pictures.Insert(.SelectedItems(i))
                
                mergedWidth = cell.MergeArea.Width
                mergedHeight = cell.MergeArea.Height
                
                Dim aspectRatio As Double
                aspectRatio = pic.Width / pic.Height
                
                If aspectRatio >= 1 Then
                    pic.Width = mergedWidth
                    pic.Height = mergedWidth / aspectRatio
                Else
                    pic.Height = mergedHeight
                    pic.Width = mergedHeight * aspectRatio
                End If
                
                pic.Left = cell.MergeArea.Left
                pic.Top = cell.MergeArea.Top
            Next i
        End If
    End With

End Sub

​

As a result, the Select Image File dialog box will open.

• Choose the intended images and hit OK.

​

Finally, we will see an output like the following one.

​

Hopefully, the Idea will fulfill your requirements. I am also attaching the solution workbook. Good luck!

Regards
Lutfor Rahman Shimanto

 

[vipin.panchal2008]

Hello VipinPanchal2008

You are most welcome to the ExcelDemy Forum. Thanks for reaching out and posting your queries.

You wanted to insert multiple images in merged cells. I am delighted to inform you that I have developed an Excel VBA sub-procedure to reach your goal. Thanks for the code you provided.

Navigate to Developer >> click on Visual Basic.

View attachment 776​

Due to this, the VBA Editor window will appear.

• Hover over Insert and click on Module.
• Insert the following code and Run.

Sub InsertImagesInMergedCells()
  
    Dim cellAddresses As Variant
    Dim cellAddress As Variant
    Dim imgFile As Variant
    Dim pic As Picture
    Dim i As Long
    Dim cell As Range
    Dim mergedWidth As Double
    Dim mergedHeight As Double
  
    cellAddresses = Array("B5", "H5", "B31", "H31")
  
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select Image Files"
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif; *.bmp", 1
        .AllowMultiSelect = True
      
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                cellAddress = cellAddresses(i - 1)
              
                Set cell = ThisWorkbook.Sheets("Sheet1").Range(cellAddress)
                Set pic = cell.Parent.Pictures.Insert(.SelectedItems(i))
              
                mergedWidth = cell.MergeArea.Width
                mergedHeight = cell.MergeArea.Height
              
                Dim aspectRatio As Double
                aspectRatio = pic.Width / pic.Height
              
                If aspectRatio >= 1 Then
                    pic.Width = mergedWidth
                    pic.Height = mergedWidth / aspectRatio
                Else
                    pic.Height = mergedHeight
                    pic.Width = mergedHeight * aspectRatio
                End If
              
                pic.Left = cell.MergeArea.Left
                pic.Top = cell.MergeArea.Top
            Next i
        End If
    End With

End Sub

View attachment 777​

As a result, the Select Image File dialog box will open.

• Choose the intended images and hit OK.

View attachment 778​

Finally, we will see an output like the following one.

View attachment 779​

Hopefully, the Idea will fulfill your requirements. I am also attaching the solution workbook. Good luck!

Regards
Lutfor Rahman Shimanto

when i run code its insert all pics in starting cells, not in other.

 

[Lutfor Rahman Shimanto]

when i run code its insert all pics in starting cells, not in other.

Hello Vipinpanchal2008

Thanks for your comment and for noticing the problem. After investigating the issue, I recommend you define the cellAddress variable as ranges instead of cells.

For example,

    cellAddresses = Array("B5:L29", "B31:L55", "B64:L86", "B88:L112")

The idea will overcome the problem. good luck!

Regards
Lutfor Rahman Shimanto