Centering Multiple Images in an Excel Column

[JacksonTriggs]

Hi,

Despite a previous similar post on this subject, it was recommended I post a newer thread question because the original is quite old. I have very limited knowledge about VBA/macros.

I have an Excel spreadsheet with about 20 rows and 2 columns. The first column has an image in each row, however, they're not centered in their respective cells. I would like to fix this. I tried one of the VBA codes from that post (quoted below) but it only does a single, active cell instead of all images in the entire column. Also, when I try to repeat that Macro on a separate cell/image, it forces an error (sorry, I lost track of that code).

Screenshot of my spreadsheet:

Hoping someone might be able to help please. Thank in advance!

Code:

Const inDebug As Boolean = False

Sub CenterPictureIfInActiveCell()
   
'If the Top-Left corner of any Picture is located within the Active Cell
'Then center the picture within the Active Cell


    Dim Pic As Picture
   
    For Each Pic In ActiveSheet.Pictures
   
        If inDebug Then MsgBox Pic.Name
   
        If isInBetween(ActiveCell.Left - 1, ActiveCell.Left + ActiveCell.Width, Pic.Left) And _
           isInBetween(ActiveCell.Top - 1, ActiveCell.Top + ActiveCell.Height, Pic.Top) _
           Then
                Pic.Left = ActiveCell.Left + ((ActiveCell.Width - Pic.Width) / 2)
                Pic.Top = ActiveCell.Top + ((ActiveCell.Height - Pic.Height) / 2)
        End If
       
    Next Pic
      
End Sub


Function isInBetween(lowVal As Long, hiVal As Long, targetVal As Long, Optional Inclusive As Boolean = True) As Boolean


'Return TRUE if the targetVal is between the lowVal and hiVal (Inclusive optional)


    isInBetween = False

 

[JacksonTriggs]

I should add that despite this document having only 20-30 rows, most have over 300 so I'd like to use a macro instead of manually modifying image positioning.

 

[GWteB]

The code below is most likely to do what you want.

Public Sub CenterAllPicturesInCell()
    
    Dim Pic As Picture
    Application.ScreenUpdating = False
    For Each Pic In ActiveSheet.Pictures
        With Pic.TopLeftCell
            If .Width > Pic.Width And .Height > Pic.Height Then
                If isInBetween(.Left - 1, .Left + .Width, Pic.Left) And isInBetween(.Top - 1, .Top + .Height, Pic.Top) Then
                    Pic.Left = .Left + ((.Width - Pic.Width) / 2)
                    Pic.Top = .Top + ((.Height - Pic.Height) / 2)
                End If
            End If
        End With
    Next Pic
    Application.ScreenUpdating = True
End Sub


Public Function isInBetween(lowVal As Long, hiVal As Long, targetVal As Long, Optional Inclusive As Boolean = True) As Boolean
    'Return TRUE if the targetVal is between the lowVal and hiVal (Inclusive optional)
    If Inclusive Then
        Select Case targetVal
        Case Is < lowVal
        Case Is > hiVal
        Case Else
            isInBetween = True
        End Select
    Else
        Select Case targetVal
        Case Is <= lowVal
        Case Is >= hiVal
        Case Else
            isInBetween = True
        End Select
    End If
End Function

 

[JacksonTriggs]

Dear GWteB,

You are a rock star! It worked perfectly. Thank you!!!

 

[GWteB]

You are welcome and thanks for the feedback.

 

[JacksonTriggs]

I don't mean to push it, and I'm sorry for this additional request, but is it possible to made a slight modification to make the images align top-left instead? My bad.

 

[GWteB]

That requires much less code:

Public Sub JacksonTriggs()
    Dim Pic As Picture
    Application.ScreenUpdating = False
    For Each Pic In ActiveSheet.Pictures
        With Pic.TopLeftCell
            Pic.Left = .Left
            Pic.Top = .Top
        End With
    Next Pic
    Application.ScreenUpdating = True
End Sub

 

[JacksonTriggs]

Once again, thank you GWteB! You're a VBA LEGEND!

 

[gougouna]

Dear @GWteB !

thank You very much