PDA

View Full Version : Reformatting Images in Merged Cells



125ml
10-18-2016, 12:38 PM
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
10-19-2016, 12:03 AM
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
10-19-2016, 10:51 AM
Thank you very much for your swift reply!
I will try this out and let you know if it works.
My best,

Reno

125ml
10-20-2016, 03:21 PM
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
17382

mana
10-21-2016, 03:40 AM
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