Reformatting Images in Merged Cells

[125ml]

Hello!

I am currently working on integrating images for all products in our ERP, so that if I do an extraction of the stock on hand I can easily identify which product is concerned. However, I can only add 1 image per reference, even if there are multiple SKU's.
This means that when I extract an Excel file that has a reference with 8 different colourways for example, I have the same image 8 times.
For this I have already found the solution with the code below that merges all cells that have the same image and deletes 7 out of the 8 images.
So far so good and this code works rather efficiently. However, the images are also too small from the current extraction and I would like to resize all remaining images as well as center them in the newly merged cell. Would anyone be able to help out and advise if it's possible to elegantly include these additional functionalities in the same loop?

Thanks in advance!

Chees,

Reno

Current Code:

Sub Merge_Image_Cells()


Dim i As Long
Dim myLastRow As Long


Application.DisplayAlerts = False


myLastRow = Cells(Rows.Count, "I").End(xlUp).Row


For i = myLastRow To 1 Step -1
If Cells(i, 9) = Cells(i + 1, 9) Then
ActiveSheet.Shapes.Range(Array("Picture " & i)).Select
Selection.Delete
Range(Cells(i, 11), Cells(i + 1, 11)).Merge
End If
Next i


Application.DisplayAlerts = True
'
End Sub

[mana]

Option Explicit

Sub test()
    Dim sp As Shape
    Dim st As Long, en As Long
    Dim i As Long
    Dim L As Double, T As Double, W As Double, H As Double
    Dim datCol As Long, spCol As Long
    
    datCol = Columns("I").Column
    spCol = Columns("K").Column

    For Each sp In ActiveSheet.Shapes
        If sp.TopLeftCell.Column = spCol Then
            sp.Name = "PIC_125mL-" & sp.TopLeftCell.MergeArea.Row
        End If
    Next
    
    st = 1
    en = st
    
    For i = 2 To Cells(Rows.Count, datCol).End(xlUp).Row + 1
    
        If Cells(st, datCol).Value = Cells(i, datCol).Value Then
        
            en = i
            On Error Resume Next
            If en > st Then ActiveSheet.Shapes("PIC_125mL-" & i).Delete
            On Error GoTo 0
            
        Else
            Range(Cells(st, spCol), Cells(en, spCol)).Merge
            
            With Cells(st, spCol).MergeArea
                L = .Left
                T = .Top
                H = .Height
                W = .Width
                
                With ActiveSheet.Shapes("PIC_125mL-" & st)
                    .LockAspectRatio = msoTrue
                    .Left = L
                    .Top = T + (H - .Height) / 2
                    .Width = W
                End With
                
            End With
            
            st = i
            en = st
            
        End If
    Next

End Sub

[125ml]

Thank you very much for your swift reply!
I will try this out and let you know if it works.
My best,

Reno

[125ml]

Dear Mana,

Thanks again for your kind help, however I cannot seem to get the second part of the code to work, the Merge function is not recognized...
Any chance you could have a look at it or eventually add some comments regarding the code?
I have also attached a test file.
Thank you very much in advance.

Reno
Export Images - Test V1.xlsm

[mana]

Option Explicit

Sub test2()
    Dim sp As Shape
    Dim st As Long, en As Long
    Dim i As Long
    Dim L As Double, T As Double, W As Double, H As Double
    Dim r As Double
    Dim datCol As Long, spCol As Long
    Const startRow As Long = 2  'without table header
     
    datCol = Columns("I").Column
    spCol = Columns("K").Column
     
    For Each sp In ActiveSheet.Shapes
        If sp.TopLeftCell.Column = spCol Then
            sp.Name = "PIC_125mL-" & sp.TopLeftCell.MergeArea.Row
        End If
    Next
     
    st = startRow
    en = st
     
    For i = startRow + 1 To Cells(Rows.Count, datCol).End(xlUp).Row + 1
         
        If Cells(st, datCol).Value = Cells(i, datCol).Value Then
             
            en = i
            On Error Resume Next
            If en > st Then ActiveSheet.Shapes("PIC_125mL-" & i).Delete
            On Error GoTo 0
             
        Else
            Range(Cells(st, spCol), Cells(en, spCol)).Merge
             
            With Cells(st, spCol).MergeArea
                L = .Left
                T = .Top
                H = .Height
                W = .Width
                 
                With ActiveSheet.Shapes("PIC_125mL-" & st)
                    .LockAspectRatio = msoTrue
                    r = WorksheetFunction.Min(W / .Width, H / .Height)
                    .Left = L + (W - .Width * r) / 2
                    .Top = T + (H - .Height * r) / 2
                    .Width = .Width * r
                End With
                 
            End With
             
            st = i
            en = st
             
        End If
    Next
     
End Sub