Replace text in cell with picture (or insert picture into same cell)

[plainhavoc]

Hi all, this is my first post here, and hope to help others in the future! Right now, though I am at a loss as to what to do.

I currently have a workbook with two sheets (developing with 2013, but also needs to work for 2007 if possible).
The first sheet is the printout form (picture 1), and the second is where the data is entered (picture 2).

The VBA runs through each row (see module snippets below) and populates the data in the correct cells, and then prints the form out.

What I would like to do, is during this process, if the text "z.1" through "z.9" is entered, it is replaced with a picture, or at least a corresponding picture would be entered into the same cell as the text (key in pic 2). These nine pictures are located in a subfolder of the same directory in which the excel file will be located (usb stick, which means drive letter will change between systems).

Currently, my wife attempts to do these sheets in word (using tables) that continue to overlap each other. Just trying to save her some time and frustration.
Any help on this would be greatly appreciated!


Here is what I have so far for the populate and print.


'This populates the Kardex sheet with each row.Sub PropagateForm()
Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, lr As Long
Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws2 = Worksheets("PRINT_LIST")
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
For r = 3 To lr
Range("B7").Value = ws2.Range("A" & r).Value
Range("E7").Value = ws2.Range("B" & r).Value
Range("E8").Value = ws2.Range("C" & r).Value
Range("E9").Value = ws2.Range("D" & r).Value
Range("E10").Value = ws2.Range("E" & r).Value
Range("E13").Value = ws2.Range("F" & r).Value
Range("E16").Value = ws2.Range("G" & r).Value
Range("F7").Value = ws2.Range("H" & r).Value
Range("F8").Value = ws2.Range("I" & r).Value
Range("F9").Value = ws2.Range("J" & r).Value
Range("F10").Value = ws2.Range("K" & r).Value
Range("F13").Value = ws2.Range("L" & r).Value
Range("F16").Value = ws2.Range("M" & r).Value
Range("H7").Value = ws2.Range("N" & r).Value
Range("H8").Value = ws2.Range("O" & r).Value
Range("H9").Value = ws2.Range("P" & r).Value
Range("H10").Value = ws2.Range("Q" & r).Value
Range("H16").Value = ws2.Range("R" & r).Value
Range("K7").Value = ws2.Range("S" & r).Value
Range("K8").Value = ws2.Range("T" & r).Value
Range("K9").Value = ws2.Range("U" & r).Value
Range("K10").Value = ws2.Range("V" & r).Value
Range("K13").Value = ws2.Range("W" & r).Value
Range("K16").Value = ws2.Range("X" & r).Value
Range("P7").Value = ws2.Range("Y" & r).Value
Range("P8").Value = ws2.Range("Z" & r).Value
Range("P9").Value = ws2.Range("AA" & r).Value
Range("P10").Value = ws2.Range("AB" & r).Value
Range("P13").Value = ws2.Range("AC" & r).Value
Range("P16").Value = ws2.Range("AD" & r).Value
Call PrintSave
Next r
End With
Application.DisplayAlerts = False
ThisWorkbook.Close False
'Application.Quit
End Sub
________________________________________________
Sub PrintSave()
PrintKardex
'CreateDir
'ExportPDF
'SaveStickerNewName
End Sub
_________________________________________________
Sub PrintKardex()
'below will print one copy of Kardex but change number to what is needed
ActiveSheet.PrintOut Copies:=1
End Sub





1920419205

[werafa]

I can see a few ideas.

1: you can get the path by getting the workbook.path and appending the sub-directory. there are a few options for this, so check it out on google.
2: code to paste an image: try the macro recorder. I'm confident that you can specify the top left position of an object, and then can specify its dimensions. try to paste your image, then define it as an object and then position it as separate actions. I believe you can read the absolute position of a cell in order to obtain the location info


you can also try an alternative approach and set up a user form. they are a pain in the B to get working and looking pretty, but they allow you to do much more than you can in native excel.

Werafa

[mdmackillop]

Much easier if you put the pictures on a hidden sheet in the workbook.

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Select Case LCase(Target.Formula)
Case "z.1"
Sheets("Sheet2").Shapes("Picture 1").Copy
Case "z.2"
Sheets("Sheet2").Shapes("Picture 2").Copy
'etc.
End Select
ActiveSheet.Paste
Selection.Top = Target.Top
Target.Select
End Sub


Alternative for subfolder

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Call Test2(Target)
End Sub


Sub Test2(Target)
Dim Pth As String
Dim Pic As Object
Pth = ActiveWorkbook.Path & "\Pics\"
Select Case LCase(Target.Formula)
Case "z.1"
Set Pic = ActiveSheet.Pictures.Insert(Pth & "Pic1.jpg")
Case "z.2"
Set Pic = ActiveSheet.Pictures.Insert(Pth & "Pic2.jpg")
'etc.
End Select
Pic.Top = Target.Top
End Sub

[plainhavoc]

Thank you so much, and my apologies for such a long delay in replying.

mdmackillop, I attempted your first choice, and made a third worksheet (The original 2 were occupied with the print_list and Kardex_printout). The pictures were inserted there, and labeled pic 1-9 respectively. Then added your first script (finishing through to pic9), and attempted.

When reaching the "If Target.Count >1 Then Exit Sub" I get an error 91. So, by commenting that out, it continues to "Select Case Case (Target.Formula)" which also results in an error 91.

There are only six rows populated with information presently for testing, and it is attempting to print 316 pages. Any clue why it would not detect the last row?

Here is the entire scrip as it is currently sitting.


'This populates the Kardex sheet with each row.



Sub PropagateForm()
Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, lr As Long
Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws2 = Worksheets("PRINT_LIST")
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
For r = 3 To lr
Range("B7").Value = ws2.Range("A" & r).Value
Range("E7").Value = ws2.Range("B" & r).Value
Range("E8").Value = ws2.Range("C" & r).Value
Range("E9").Value = ws2.Range("D" & r).Value
Range("E10").Value = ws2.Range("E" & r).Value
Range("E13").Value = ws2.Range("F" & r).Value
Range("E16").Value = ws2.Range("G" & r).Value
Range("F7").Value = ws2.Range("H" & r).Value
Range("F8").Value = ws2.Range("I" & r).Value
Range("F9").Value = ws2.Range("J" & r).Value
Range("F10").Value = ws2.Range("K" & r).Value
Range("F13").Value = ws2.Range("L" & r).Value
Range("F16").Value = ws2.Range("M" & r).Value
Range("H7").Value = ws2.Range("N" & r).Value
Range("H8").Value = ws2.Range("O" & r).Value
Range("H9").Value = ws2.Range("P" & r).Value
Range("H10").Value = ws2.Range("Q" & r).Value
Range("H16").Value = ws2.Range("R" & r).Value
Range("K7").Value = ws2.Range("S" & r).Value
Range("K8").Value = ws2.Range("T" & r).Value
Range("K9").Value = ws2.Range("U" & r).Value
Range("K10").Value = ws2.Range("V" & r).Value
Range("K13").Value = ws2.Range("W" & r).Value
Range("K16").Value = ws2.Range("X" & r).Value
Range("P7").Value = ws2.Range("Y" & r).Value
Range("P8").Value = ws2.Range("Z" & r).Value
Range("P9").Value = ws2.Range("AA" & r).Value
Range("P10").Value = ws2.Range("AB" & r).Value
Range("P13").Value = ws2.Range("AC" & r).Value
Range("P16").Value = ws2.Range("AD" & r).Value
Call PrintSave
Next r
End With
Application.DisplayAlerts = False
ThisWorkbook.Close False
'Application.Quit
End Sub




Sub PrintSave()
Worksheet_change
PrintKardex
'CreateDir
'ExportPDF
'SaveStickerNewName
'NextSticker
End Sub




Private Sub Worksheet_change(Optional ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Select Case LCase(Target.Formula)
Case "z.1"
Sheets("pics").Shapes("Picture 1").Copy
Case "z.2"
Sheets("pics").Shapes("Picture 2").Copy
Case "z.3"
Sheets("pics").Shapes("Picture 3").Copy
Case "z.4"
Sheets("pics").Shapes("Picture 4").Copy
Case "z.5"
Sheets("pics").Shapes("Picture 5").Copy
Case "z.6"
Sheets("pics").Shapes("Picture 6").Copy
Case "z.7"
Sheets("pics").Shapes("Picture 7").Copy
Case "z.8"
Sheets("pics").Shapes("Picture 8").Copy
Case "z.9"
Sheets("pics").Shapes("Picture 9").Copy
End Select
ActiveSheet.Paste
Selection.Top = Target.Top
Target.Select
End Sub




Sub PrintKardex()
'below will print one copy of Kardex but change to what is needed
ActiveSheet.PrintOut Copies:=1
End Sub

[werafa]

try if target.cells.count......
also, not sure if your target.formula should be target.value, or possibly target.value2.

try it and see

[plainhavoc]

try if target.cells.count......
also, not sure if your target.formula should be target.value, or possibly target.value2.

try it and see

Thank you werafa, but still running into an error 91 at that point. Should I mention that the form being filled by text has merged cells? That might change the game a bit.

[plainhavoc]

I have uploaded the file in question (and thorn in my side) to Expirebox for anyone to test with. It has a 2 day limit before being deleted. No malicious code. The module has been posted above.

https:// expirebox.com/ download/ 3cccda93c67756167c1ee08e07a5adfd. html

Any help on this would be eternally appreciated!

[mdmackillop]

Can you post your file using Go Advanced/Manage Attachments

[mdmackillop]

Note: your code has been amended. Use these
This should go in the KARDEX sheet module

Private Sub Worksheet_change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Select Case LCase(Target.Formula)
Case "z.1"
Sheets("pics").Shapes("Picture 1").Copy
Case "z.2"
Sheets("pics").Shapes("Picture 2").Copy
Case "z.3"
Sheets("pics").Shapes("Picture 3").Copy
Case "z.4"
Sheets("pics").Shapes("Picture 4").Copy
Case "z.5"
Sheets("pics").Shapes("Picture 5").Copy
Case "z.6"
Sheets("pics").Shapes("Picture 6").Copy
Case "z.7"
Sheets("pics").Shapes("Picture 7").Copy
Case "z.8"
Sheets("pics").Shapes("Picture 8").Copy
Case "z.9"
Sheets("pics").Shapes("Picture 9").Copy
End Select
ActiveSheet.Paste
Selection.Top = Target.Top
Target.Select
End Sub


This should go in a standard module

Sub PropagateForm()
Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, lr As Long

On Error GoTo Exits
Application.EnableEvents = False

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws2 = Worksheets("PRINT_LIST")
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
For r = 3 To lr
.Range("B7").Value = ws2.Range("A" & r).Value
.Range("E7").Value = ws2.Range("B" & r).Value
.Range("E8").Value = ws2.Range("C" & r).Value
.Range("E9").Value = ws2.Range("D" & r).Value
.Range("E10").Value = ws2.Range("E" & r).Value
.Range("E13").Value = ws2.Range("F" & r).Value
.Range("E16").Value = ws2.Range("G" & r).Value
.Range("F7").Value = ws2.Range("H" & r).Value
.Range("F8").Value = ws2.Range("I" & r).Value
.Range("F9").Value = ws2.Range("J" & r).Value
.Range("F10").Value = ws2.Range("K" & r).Value
.Range("F13").Value = ws2.Range("L" & r).Value
.Range("F16").Value = ws2.Range("M" & r).Value
.Range("H7").Value = ws2.Range("N" & r).Value
.Range("H8").Value = ws2.Range("O" & r).Value
.Range("H9").Value = ws2.Range("P" & r).Value
.Range("H10").Value = ws2.Range("Q" & r).Value
.Range("H16").Value = ws2.Range("R" & r).Value
.Range("K7").Value = ws2.Range("S" & r).Value
.Range("K8").Value = ws2.Range("T" & r).Value
.Range("K9").Value = ws2.Range("U" & r).Value
.Range("K10").Value = ws2.Range("V" & r).Value
.Range("K13").Value = ws2.Range("W" & r).Value
.Range("K16").Value = ws2.Range("X" & r).Value
.Range("P7").Value = ws2.Range("Y" & r).Value
.Range("P8").Value = ws2.Range("Z" & r).Value
.Range("P9").Value = ws2.Range("AA" & r).Value
.Range("P10").Value = ws2.Range("AB" & r).Value
.Range("P13").Value = ws2.Range("AC" & r).Value
.Range("P16").Value = ws2.Range("AD" & r).Value
Call PrintSave
Next r
End With
Exits:
Application.EnableEvents = True
Application.DisplayAlerts = True
ThisWorkbook.Close False
'Application.Quit
End Sub

Sub PrintSave()
PrintKardex
'CreateDir
'ExportPDF
'SaveStickerNewName
'NextSticker
End Sub

Sub PrintKardex()
'below will print one copy of Kardex but change to what is needed
ActiveSheet.PrintOut Copies:=1
End Sub

[plainhavoc]

Note: your code has been amended. Use these
This should go in the KARDEX sheet module

Private Sub Worksheet_change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Select Case LCase(Target.Formula)
Case "z.1"
Sheets("pics").Shapes("Picture 1").Copy
Case "z.2"......
'This has been abridged to save space. See full code above.
End Sub


Embarrassingly, I have never added code to just a sheet. Just to make sure this was done correctly, I right-clicked the form tab titled "KARDEX_PRINTOUT" and selected "View Code". There, this was added. Was this the correct workflow to do this? If so, it didn't work.


This should go in a standard module

Sub PropagateForm()
Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, lr As Long

On Error GoTo Exits
Application.EnableEvents = False

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws2 = Worksheets("PRINT_LIST")
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
For r = 3 To lr
.Range("B7").Value = ws2.Range("A" & r).Value
.Range("E7").Value = ws2.Range("B" & r).Value
'This has been abridged to save space. Please see full code in comments above.
Call PrintSave
Next r
End With
Exits:
Application.EnableEvents = True
Application.DisplayAlerts = True
ThisWorkbook.Close False
'Application.Quit
End Sub

Sub PrintSave()
PrintKardex
'CreateDir
'ExportPDF
'SaveStickerNewName
'NextSticker
End Sub

Sub PrintKardex()
'below will print one copy of Kardex but change to what is needed
ActiveSheet.PrintOut Copies:=1
End Sub


This section was all added to a regular module (the unabridged version from your previous post). While running through it with F8, it did still enter the text into the proper cells, and print out the first sheet. The Private Sub seemed to have no impact on the rest. Hopefully, it is my lack of understanding that has caused this. Any thoughts?

[werafa]

There can be unexpected results from adding your code to sheet modules, such as deleting the sheet.......
so it is good practice to write your code in standard modules and call them from sheet modules if required.

Sheet modules are particularly valuable as the home of sheet events, and can trigger code by selecting or editing a cell, along with a host of other goodies

[werafa]

There can be unexpected results from adding your code to sheet modules, such as deleting the sheet.......
so it is good practice to write your code in standard modules and call them from sheet modules if required.

Sheet modules are particularly valuable as the home of sheet events, and can trigger code by selecting or editing a cell, along with a host of other goodies

you have a worksheet change event. any change to the worksheet should trigger it, and it should then pass the affected cell as an object variable. Put a break in at the 'if target.count.....' line to see
1 - if it is being triggered (you could have worksheet events turned off)
2 - if it is not calling the subroutine

[werafa]

run application.enableevents from your immediate window.

[mdmackillop]

Haven't got your file but try this. Pics can be inserted using Events or called by propagate code

Sub AddPics(ws)
Dim c As Range, i As Long
For i = 1 To 9
Set c = ws.Cells.Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
Sheets("Pics").Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
End If
Next i
End Sub

[plainhavoc]

Haven't got your file but try this. Pics can be inserted using Events or called by propagate code

Sub AddPics(ws)
Dim c As Range, i As Long
For i = 1 To 9
Set c = ws.Cells.Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
Sheets("Pics").Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
End If
Next i
End Sub





Odd, I wasn't able to get this to work, or the attached xlsm (Though I am accessing the system remotely at the moment, so there could be a dozen printouts waiting at home).

There has been some headway gained by changing the sub to this:


Sub AddPics() Dim ws1 As Worksheet
Dim ws3 As Worksheet
Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws3 = Worksheets("pics")
Dim c As Range, i As Long
For i = 1 To 9
Set c = ws1.Cells.Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
ws3.Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
End If
Next i
End Sub

The only challenge now, is that the pictures are inserting at the form's top (along with the reader's key) instead of the cell where the text [z.1 - z.9 ] is. Should the range be called again?

[mdmackillop]

The Event macro asks you to confirm the row you use for z.1 etc.

Private Sub Worksheet_change(ByVal Target As Range)
'adjust to suit
If Target.Row <> 1 Then Exit Sub


The alternative AddPics code will search the sheet for z.1 etc. and insert the pictures at these positions.

For i = 1 To 9
Set c = ws.Cells.Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
Sheets("Pics").Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
End If
Next i

[plainhavoc]

The Event macro asks you to confirm the row you use for z.1 etc.

Private Sub Worksheet_change(ByVal Target As Range)
'adjust to suit
If Target.Row <> 1 Then Exit Sub




I guess this is where my understanding is less than adequate. Where would this be called in the module? Also, there could be multiple instances of "z.1", etc. throughout the spreadsheet (though never more than one per cell).

Attached is the current semi-working xlsm for reference.

[mdmackillop]

Delete the Event macro.

This will add pictures to cells containing z.1 - z.9 wherever the are place on the sheet

Sub AddPics()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim c As Range, i As Long
Dim FA As String

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws3 = Worksheets("pics")
With ws1.Cells
For i = 1 To 9
Set c = .Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
FA = c.Address
Do
ws3.Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
Set c = .FindNext(c)
Loop While Not c Is Nothing And FA <> c.Address
End If
Next i
End With
End Sub

[plainhavoc]

Amazing, this is almost working perfectly mdmackillop! Thank you!

The last few pieces of the puzzle; After a few cycles through, it seems to stop searching, and not replace pictures in every cell with a z-code.

Another goal is trying to allow other text in the cells along with the z-code if it exists. Asterisks seem to not help in this situation. How could I allow it to still work with a string such as [somename z.6 with precautions for someaction]?



Also, it seems to not clear the images when cycling through to the next row (test resident 2), which I have added another sub that should take care of that (bottom sub).


Here is the code now as it sits. An updated test file with two data entry rows is attached. It is almost there, and thank you again for all of your insights. : pray2:


'This populates the Kardex sheet with each row.Sub PropagateForm()
Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, lr As Long

On Error GoTo Exits
Application.EnableEvents = False

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws2 = Worksheets("PRINT_LIST")
lr = ws2.Cells(Rows.Count, "A").End(xlUp).Row
With ws1
For r = 3 To lr
.Range("B7").Value = ws2.Range("A" & r).Value
.Range("E7").Value = ws2.Range("B" & r).Value
.Range("E8").Value = ws2.Range("C" & r).Value
.Range("E9").Value = ws2.Range("D" & r).Value
.Range("E10").Value = ws2.Range("E" & r).Value
.Range("E13").Value = ws2.Range("F" & r).Value
.Range("E16").Value = ws2.Range("G" & r).Value
.Range("F7").Value = ws2.Range("H" & r).Value
.Range("F8").Value = ws2.Range("I" & r).Value
.Range("F9").Value = ws2.Range("J" & r).Value
.Range("F10").Value = ws2.Range("K" & r).Value
.Range("F13").Value = ws2.Range("L" & r).Value
.Range("F16").Value = ws2.Range("M" & r).Value
.Range("H7").Value = ws2.Range("N" & r).Value
.Range("H8").Value = ws2.Range("O" & r).Value
.Range("H9").Value = ws2.Range("P" & r).Value
.Range("H10").Value = ws2.Range("Q" & r).Value
.Range("H16").Value = ws2.Range("R" & r).Value
.Range("K7").Value = ws2.Range("S" & r).Value
.Range("K8").Value = ws2.Range("T" & r).Value
.Range("K9").Value = ws2.Range("U" & r).Value
.Range("K10").Value = ws2.Range("V" & r).Value
.Range("K13").Value = ws2.Range("W" & r).Value
.Range("K16").Value = ws2.Range("X" & r).Value
.Range("P7").Value = ws2.Range("Y" & r).Value
.Range("P8").Value = ws2.Range("Z" & r).Value
.Range("P9").Value = ws2.Range("AA" & r).Value
.Range("P10").Value = ws2.Range("AB" & r).Value
.Range("P13").Value = ws2.Range("AC" & r).Value
.Range("P16").Value = ws2.Range("AD" & r).Value
Call PrintSave
Next r
End With
Exits:
Application.EnableEvents = True
Application.DisplayAlerts = True
ThisWorkbook.Close False
'Application.Quit
End Sub

Sub PrintSave()
AddPics
PrintKardex
'CreateDir
'ExportPDF
'SaveStickerNewName
'NextSticker
End Sub

Sub PrintKardex()
'below will print one copy of Kardex but change to what is needed
ActiveSheet.PrintOut Copies:=1
'Now to clear existing pics before the next row
ClearPics
End Sub




Sub AddPics()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim c As Range, i As Long
Dim FA As String

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws3 = Worksheets("pics")
With ws1.Cells
For i = 1 To 9
Set c = .Find("z." & i, lookat:=xlWhole)
If Not c Is Nothing Then
FA = c.Address
Do
ws3.Shapes("Picture " & i).Copy
c.PasteSpecial xlPasteAll
Set c = .FindNext(c)
Loop While Not c Is Nothing And FA <> c.Address
End If
Next i
End With
End Sub


Sub ClearPics()
Dim s As String
Dim pic As Picture
Dim rng As Range


' Set ws = ActiveSheet
Set ws1 = ActiveWorkbook.Worksheets("KARDEX_PRINTOUT")


Set rng = ws1.Range("active")


For Each pic In ActiveSheet.Pictures
With pic
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
End With
If Not Intersect(rng, ws1.Range(s)) Is Nothing Then
pic.Delete
End If
Next


End Sub





After this project, it is clear there is still much to learn, and my most sincere appreciation for your teachings!

[mdmackillop]

Sub AddPics()
Dim ws1 As Worksheet
Dim ws3 As Worksheet
Dim c As Range, i As Long
Dim FA As String
Dim dict As Object, key

Set ws1 = Worksheets("KARDEX_PRINTOUT")
Set ws3 = Worksheets("pics")

Set dict = CreateObject("Scripting.Dictionary")
Set rng = ws1.Range("B7:Q17")
For Each cel In rng.SpecialCells(xlCellTypeConstants)
For i = 1 To 9
If InStr(1, cel, "z." & i) Then
If Not dict.exists(cel.Formula) Then dict.Add cel.Formula, CStr(i)
End If
Next i
Next cel

Call ClearPics(ws1)

With ws1.Cells
For Each key In dict.Keys
Set c = .Find(key, lookat:=xlWhole)
If Not c Is Nothing Then
FA = c.Address
Do
ws3.Shapes("Picture " & dict(key)).Copy
c.PasteSpecial xlPasteAll
Set c = .FindNext
Loop While Not c Is Nothing And FA <> c.Address
End If
Next key
End With
End Sub


Sub ClearPics(ws1 As Worksheet)
Dim s As String
Dim pic As Shape
Dim rng As Range

Set rng = ws1.Range("B7:Q17")
For Each pic In ws1.Shapes
With pic
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
End With
If Not Intersect(rng, ws1.Range(s)) Is Nothing Then
pic.Delete
End If
Next
End Sub

[plainhavoc]

Thank you so much, this works like a charm!

For educational purposes, how does the "Call ClearPics(ws1)" work where it does?

I initially thought with it ordered in that manner, it would clear the pictures as soon as it cycled through each one in the loop. I guess my understanding of the logic is far too insufficient at present.

Again, thank you so much! Now my wife won't have to spend countless hours at home changing these for her retirement home employer.

[mdmackillop]

On the assumption the layout may change, it seemed best to remove any existing pictures from the range prior to adding new ones. You could make this a separate procedure.

[plainhavoc]

That makes sense now. Again, thank you so much! Her workload has gone from spending around 3 hours doing this, down to around 10 minutes. Now she and I can actually spend some time together! :yes