Problem with this code to put pictures into cells in Excel

[tonywatsonhelp]

Hi Everyone,
The code below is supposed to copy pictures and put them into the cell

basically, if you imagine a seat planner, I have a huge area made up of small square cells, the idea is to allocate where in the room I want people to sit and place seat numbers into those cells,
I have 100 pictures of seats with numbers written on them and I want a macro that goes through the range and if a cell has a number in it copies that seats image to the cell,

it all runs great for about 20 to 50 seats then the clipboard gets full up (as far as I can tell) and it crashes.

can you help edit my macro so it won't do this? its really frustrating that it works at first then crashes,

I'm happy for a total rewrite if that's what it needs but basically just need it to work, we are starting to get a lot of weddings coming in and this will be a great way to built the seat plans if it works.
thanks
Tony


heres my code as it stands:

Sub Add_yellow_Seats()

    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    
    ' Define the worksheet
    Set ws = ActiveSheet ' Change "Sheet1" to your sheet name

    ' Define the range
    LRc = ws.Cells(Rows.Count, "G").End(xlUp).Row
    Set rng = ws.Range("AA5:DZ" & LRc)

    For Each cell In rng
    If cell.Value >= 1 And cell.Value <= 100 Then
    y = cell.Value
Application.CutCopyMode = False
    ws.Shapes("Chair_" & y).Copy

                cell.ClearContents
                cell.PastePictureInCell
Application.CutCopyMode = False
DoEvents

End If

    Next cell
End Sub

 

[rlv01]

What about if you used a different method to paste the shapes?

Sub Add_yellow_Seats()

    Dim ws As Worksheet
    Dim rng As Range
    Dim rCell As Range                                'I have a thing about not using reserved words as variable names.
    Dim LRc As Long, y As Variant                     'always a good idea to declare all variables, not just some

    ' Define the worksheet
    Set ws = ActiveSheet                              ' Change "Sheet1" to your sheet name

    ' Define the range
    LRc = ws.Cells(Rows.Count, "G").End(xlUp).Row
    Set rng = ws.Range("AA5:DZ" & LRc)

    For Each rCell In rng
        If rCell.Value >= 1 And rCell.Value <= 100 Then
            y = rCell.Value
            ws.Shapes("Chair_" & y).Copy
            ws.Paste
            With ws.Shapes(ws.Shapes.Count)
                .Top = rCell.Top
                .Left = rCell.Left
                .Height = rCell.Height
                .Width = rCell.Width
            End With
            rCell.ClearContents
            DoEvents
        End If
    Next rCell
End Sub