images to fill the cells

[KlausW]

Hi
I have some images that are automatically inserted into cells on different sheets with this code. This works perfectly. Now I would like a Marco for the images to fill the cells.
Anyone who can help?
Any help will be appreciated.
Best Regards Klaus W
Code to insert images looks like this.

ub Find()
    Dim A, B, c, d As Range ' a = området på "Billeder 1.deling med navne på foto, b = område i "Billeder" med navne på billeder, c = de enkelte celler i a, d = de enkelte celler i b
    ActiveSheet.Pictures.Delete ' de gamle billeder slettes
    Set A = Range("a4:d4,a8:d8,a12:d12,a16:d16,a20:d20") ' a defineres
    Set B = Worksheets("Billeder").Range("a4:L12") ' b defineres
    For Each c In A
        For Each d In B
            If c = d And c <> "" Then ' der testes om de enkelte celler i a findes i b
                d.Offset(-1, 0).Copy Destination:=c.Offset(-1, 0) ' hvis de findes, kopieres cellen ovenover i "Billeder" til cellen ovenover i "Billeder 1.deling"
            End If
        Next
    Next
    
   
     
End Sub

 

[MCLIFTO8]

Do you mean size the image so that it fits within the bounds of the cell you paste it into?

 

[KlausW]

sorry for the late reply. yes, that's how I'd like it. and maybe one or two millimeters between images and the edge of the cells.

 

[MCLIFTO8]

Try this.

Sub Find()
    Dim A, B, c, d As Range ' a = området på "Billeder 1.deling med navne på foto, b = område i "Billeder" med navne på billeder, c = de enkelte celler i a, d = de enkelte celler i b
    ActiveSheet.Pictures.Delete ' de gamle billeder slettes
    Set A = Range("a4:d4,a8:d8,a12:d12,a16:d16,a20:d20") ' a defineres
    Set B = Worksheets("Billeder").Range("a4:L12") ' b defineres
    For Each c In A
        For Each d In B
            If c = d And c <> "" Then ' der testes om de enkelte celler i a findes i b
                d.Offset(-1, 0).Copy Destination:=c.Offset(-1, 0) ' hvis de findes, kopieres cellen ovenover i "Billeder" til cellen ovenover i "Billeder 1.deling"
                ResizePic(c.Offset(-1, 0).Address)
            End If
        Next
    Next
End Sub

Sub ResizePic(rngPicLocation As String)
   Const margin = 10 'margen
   Dim picCurrentPic As Picture
   Dim rngCell As Range

For Each picCurrentPic In ActiveSheet.Pictures
    If picCurrentPic.TopLeftCell.Address = Range(rngPicLocation).Address Then
        Set rngCell = picCurrentPic.TopLeftCell
        'picCurrentPic.LockAspectRatio = msoFalse
        picCurrentPic.Top = rngCell.Top + margin
        picCurrentPic.Left = rngCell.Left + margin
        picCurrentPic.Width = rngCell.Width - 2 * margin
        'picCurrentPic.Height = rngCell.Height - margin
    End If
Next picCurrentPic

End Sub

I have tested the ResizePic subroutine.
I'm not able to test it within your code but I've made a guess on where and how you would call it.

call it with "ResizePic("A1")"
set your margins with "margin = 10"

 

[jolivanes]

Dim A, B, c, d As Range

At the above, A, B and c are variants.
It should be

Dim A As Range, B As Range, c As Range, d As Range

See here for more.

VBA Dim - A Complete Guide - Excel Macro Mastery

This post provides a comprehensive guide to using the VBA Dim statement. The quick guide table shows you the format of the DIm statement and all the ways it can be used.

excelmacromastery.com

#5. How to Use Dim with Multiple Variables


What is in the cells in A? Range A is 20 cells.
What is in the cells in B? Range B is 108 cells