Centering an images in each of their cells

user_12000488 0
Viewed 53

So I have a file that has a bunch of steps listed with their information going across the row, shown in the attached image. In the fifth column, there is space for a picture. I want to be able to center the image within the cell. I would also like to have some form of consistent size but that is a problem for another day.

My current macro seems to center the images but it shifts them up and down throughout the spreadsheet into somewhat random rows. My current code is attached (can't figure out how to do it properly, am new here). to make it a bit more complicated, each row for information is actually 2 rows making selecting the next row somewhat frustrating at times.

Hopefully I explained that well, will try to answer any questions as well as I can and any help is much appreciated.

I have seen a blog by someone who made a macro that could tell if a picture was placed anywhere and would snap it to cells but I can't find this anymore. If you know or know of something similar that would also be great.

Pic of table

Public Sub ImageCentering()

    Worksheets("Steps").Activate

    Dim wShape As Shape
    Dim PicCell As Range
    Dim Row As Integer
    Row = 2

    Do While IsEmpty(Cells(Row, 2)) = False
        If IsEmpty(Cells(Row, 2)) = False Then
            For Each wShape In ActiveSheet.Shapes
                If wShape.TopLeftCell = Cells(Row, 5) Then
                    CellImageCheck = 1
                    If CellImageCheck = 1 Then
                        With wShape
                            .Top = Range(Cells(Row, 5).Address).Top + (Range(Cells(Row, 5).Address).Height - .Height) / 2
                            .Left = Range(Cells(Row, 5).Address).Left + (Range(Cells(Row, 5).Address).Width - .Width) / 2
                        End With
                        CellImageCheck = 0
                    End If
                End If
                Row = Row + 2
            Next wShape
        End If
    Loop
End Sub
module vba excel image
1 Answers

Your primary issue is with

If wShape.TopLeftCell = Cells(Row, 5) Then

What this does is compare the contents of wShape.TopLeftCell to the contents of Cells(Row, 5). You want to compare the position instead.

That said, there a a number of other issues in your code too, cleaned up below.

Public Sub ImageCentering()
    Dim ws As Worksheet
    Set ws = Worksheets("Steps")
    ws.Activate ' if you must
    
    Dim wShape As Shape
    Dim Row As Long
    Row = 2

    With ws
        Do While Not IsEmpty(.Cells(Row, 2))
            For Each wShape In .Shapes
                If wShape.TopLeftCell.Address = .Cells(Row, 5).Address Then 'HERE IS YOUR ISSUE
                    wShape.Top = .Cells(Row, 5).Top + (.Cells(Row, 5).Height - wShape.Height) / 2
                    wShape.Left = .Cells(Row, 5).Left + (.Cells(Row, 5).Width - wShape.Width) / 2
                    Exit For
                End If
            Next wShape
            Row = Row + 2
        Loop
    End With
End Sub
user_4454250
Related