VBA Copy Paste Picture On Cell Value

[Lewzerrrr]

Hi,

I have the following code that imports picture from a directory based on cell value however if the file is not there it leaves a blank, what I've then conducted is to manual copy the image from google into a separate sheet and instead of returning blank I want it to look into that sheet to try and import and THEN if not found in both sources to return blank.

As you can see in this line of code here I've added a vlookup instead to check if the value has been put in "Pictures Not Found DIR", I want to change this to something like IF .cells(X,13) is in Sheets("Pictures Not Found DIR").range("A") then return the picture that would be next to it in column B, if not return "Picture Not Found"

If you need any more clarity then let me know.

Thanks,

If FileExists(sFolder & .Cells(x, 10) & ".jpg") = False Then
j = j + 1

rngPicPosition.Offset(1, 0) = .Cells(x, 10)
rngPicPosition.Offset(2, 0) = .Cells(x, 11)
rngPicPosition.Offset(1, 1) = .Cells(x, 14)
rngPicPosition.Offset(0, -1) = .Cells(x, 5)
rngPicPosition.Offset(3, 0) = .Cells(x, 13)
rngPicPosition.Offset(3, 0).NumberFormat = "0"
rngPicPosition.Offset(3, 1) = .Cells(x, 12)
rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"
rngPicPosition.Formula = "=IF(ISNA(VLOOKUP(K6,'Pictures Not Found DIR'!$A:$D,1,0)),"""",""This picture is in the directory tab"")"

Here's the full code:

Sub Box()

Dim oNewPic As Shape
Dim shpShape As Shape
Dim rngPicPosition As Range
Dim rngRange As Range
Dim x As Long
Dim iStartColumn As Long
Dim iStartRow As Long
Dim i As Long
Dim j As Long

' Speed up processing
sbar ("Please wait ... importing pictures")
Call TurnOff

' Delete existing data, including pictures (Shapes)
For Each shpShape In template.Shapes
shpShape.Delete
Next
With template
mylr = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
mylc = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
If mylr > 4 Then
Set rngRange = .Range(.Cells(2, 2), .Cells(mylr, mylc))
rngRange.ClearContents
Call NoBorders(rngRange)
rngRange.EntireRow.Delete
End If
End With

' Insert Pictures
i = 1
j = 0
With data

mylr = LR(, .Name, "A")

For x = 4 To mylr

sbar ("Please wait ... importing picture " & i & " of " & mylr - 3)
iStartColumn = MyColLong(CStr(.Cells(x, 16).Value))

If iStartRow <> .Cells(x, 18) Then
iStartRow = .Cells(x, 18)
Worksheets(template.Name).Cells(iStartRow, 1).RowHeight = 118.75
End If

Set rngPicPosition = Worksheets(template.Name).Cells(iStartRow, iStartColumn)

If FileExists(sFolder & .Cells(x, 10) & ".jpg") = False Then
j = j + 1

rngPicPosition.Offset(1, 0) = .Cells(x, 10)
rngPicPosition.Offset(2, 0) = .Cells(x, 11)
rngPicPosition.Offset(1, 1) = .Cells(x, 14)
rngPicPosition.Offset(0, -1) = .Cells(x, 5)
rngPicPosition.Offset(3, 0) = .Cells(x, 13)
rngPicPosition.Offset(3, 0).NumberFormat = "0"
rngPicPosition.Offset(3, 1) = .Cells(x, 12)
rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"
rngPicPosition.Formula = "=IF(ISNA(VLOOKUP(K6,'Pictures Not Found DIR'!$A:$D,1,0)),"""",""This picture is in the directory tab"")"

Dim PNF As Worksheet, LR1 As Long
Set PNF = ThisWorkbook.Sheets("Pictures Not Found DIR")
LR1 = PNF.Cells(PNF.Rows.Count, "A").End(xlUp).Row + 1

PNF.Range("A" & LR1) = .Cells(x, 10)

Set rngRange = rngPicPosition.Resize(5, 2)
Call MyLineStyle(rngRange)
Else
Set oNewPic = Sheets(template.Name).Shapes.AddPicture(Filename:=sFolder & .Cells(x, 10) & ".jpg", _
linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=rngPicPosition.Left, _
Top:=rngPicPosition.Top, _
Width:=-1, Height:=-1)
With oNewPic
.Height = 100.629933
.Width = 92.6929242
.IncrementLeft 26.1
.IncrementTop 8.7
.LockAspectRatio = msoTrue
.Rotation = 0
End With

rngPicPosition.Offset(1, 0) = .Cells(x, 10)
rngPicPosition.Offset(2, 0) = .Cells(x, 11)
rngPicPosition.Offset(3, 0) = .Cells(x, 13)
rngPicPosition.Offset(3, 0).NumberFormat = "0"
rngPicPosition.Offset(1, 1) = .Cells(x, 14)
rngPicPosition.Offset(0, -1) = .Cells(x, 5)
rngPicPosition.Offset(3, 1) = .Cells(x, 12)
rngPicPosition.Offset(3, 1).NumberFormat = "$#,##0.00"

Set rngRange = rngPicPosition.Resize(5, 2)
Call MyLineStyle(rngRange)
End If
i = i + 1
Next x
End With

Set oNewPic = Nothing
Set rngPicPosition = Nothing
Set shpShape = Nothing
Set rngRange = Nothing

Call TurnOn

Call MergeCells

Call PrintArea

Call WidthHeight

mymsg = MsgBox(mylr - 3 & " Pictures have been processed, " & j & " of those were not found in the library.", vbOKOnly + vbInformation, "Information")

End Sub

 

[Lewzerrrr]

Any help?

I'm thinking if theres a function that would check if the value contains a picture next to it, to return a 1 if not 0 so that when I enter =haspic(C6) it returns the pic? and then in the loop I can add this..

rngpicposition = "=HASPIC(C6)"

Really not sure how to go about this.. but it would be an extreme life saver!

So basically in sheet1, a picture catalogue runs from a directory, if the picture isn't found I want it to look into sheet3 instead. In sheet3 column A i have the value and in column B i have the pictures. So it would be like =vlookup(Sheet1!C6,Sheet3!A:B,2,0) return picture.

Thanks,