VBA Code For Excel .......................... [Solved/Closed]

Report
-
 Santosh -
Dear Expert,

Below written VBA code is being used by me to insert jpg picture in the excel file against the code number and its working very well and i need to incorpotate a small thing is if the picture is not available in the cell for the code it should write (Picture is not available) presently it is swhoing Blank .
-------------------------------------------------------------------------------------------------------------------

Sub ProcessFiles()
Dim sPath As String, s As String, r As Range
Dim shp As ShapeRange
Dim c As Range, cell As Range, sname As String
Dim p As Picture, diffwidth As Double, diffHeight As Double
sPath = "D:\2010I\Excel Pic\Complete Range _2010I"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Set r = Range("B2", Cells(Rows.Count, 2).End(xlUp))
For Each cell In r
cell.Offset(0, 1).Select
Set c = cell.Offset(0, -1)
s = sPath & cell.Value & ".jpg" 'remove the .jpg if the cell contains the extension
sname = Dir(s)
If sname <> "" Then
Set p = ActiveSheet.Pictures.Insert(s)
Set shp = p.ShapeRange
diffwidth = c.Width - p.Width
If diffwidth > 0 Then
p.Left = c.Left + 0.5 * diffwidth
Else
p.Left = c.Left
End If

diffHeight = c.Height - p.Height
If diffHeight > 0 Then
p.Top = c.Top + 0.5 * diffHeight
Else
p.Top = c.Top
End If
End If
Next

End Sub

Please help
Rgds Santosh

2 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
765
Santosh, all you need is an else statement before the last ENDIF. Here is you whole modified code. New lines are highlighted

Sub ProcessFiles() 
Dim sPath As String, s As String, r As Range 
Dim shp As ShapeRange 
Dim c As Range, cell As Range, sname As String 
Dim p As Picture, diffwidth As Double, diffHeight As Double 

    sPath = "D:\2010I\Excel Pic\Complete Range _2010I" 
     
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\" 
     
    Set r = Range("B2", Cells(Rows.Count, 2).End(xlUp)) 
     
    For Each cell In r 
        cell.Offset(0, 1).Select 
         
        Set c = cell.Offset(0, -1) 
        s = sPath & cell.Value & ".jpg" 'remove the .jpg if the cell contains the extension 
        sname = Dir(s) 
         
        If sname <> "" Then 
            Set p = ActiveSheet.Pictures.Insert(s) 
            Set shp = p.ShapeRange 
             
            diffwidth = c.Width - p.Width 
             
            If diffwidth > 0 Then 
             p.Left = c.Left + 0.5 * diffwidth 
            Else 
                p.Left = c.Left 
            End If 
             
            diffHeight = c.Height - p.Height 
            If diffHeight > 0 Then 
             p.Top = c.Top + 0.5 * diffHeight 
            Else 
                p.Top = c.Top 
            End If 

        Else 
         c.Value = "Picture is not available" 

        End If 
    Next 

End Sub
Thank You Very Much For Making Rectification In My VBA Code.
Once Again Thanks Thanks..................................................................................................................................

Santosh

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!