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

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
 

Attachments

  • Untitled.png
    Untitled.png
    159.7 KB · Views: 8
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.
Open the VBA Editor.png

Due to this, the VBA Editor window will appear.
  • Hover over Insert and click on Module.
  • Insert the following code and Run.

Code:
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
Insert the given code in module and Run.png

As a result, the Select Image File dialog box will open.
  • Choose the intended images and hit OK.
Choose the intended images and click OK.png

Finally, we will see an output like the following one.
Output of inserting images in merged cells.png
Hopefully, the Idea will fulfill your requirements. I am also attaching the solution workbook. Good luck!

Regards
Lutfor Rahman Shimanto
 

Attachments

  • VipinPanchal2008 (SOLVED).xlsm
    19.7 KB · Views: 2
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.

Code:
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


when i run code its insert all pics in starting cells, not in other.
 
Last edited:
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,
Code:
    cellAddresses = Array("B5:L29", "B31:L55", "B64:L86", "B88:L112")

The idea will overcome the problem. good luck!

Regards
Lutfor Rahman Shimanto
 

Online statistics

Members online
0
Guests online
37
Total visitors
37

Forum statistics

Threads
337
Messages
1,470
Members
624
Latest member
duytoi
Top