VBA Code For Excel ..........................

Solved/Closed
Santosh - Apr 20, 2010 at 06:02 AM
 Santosh - Apr 20, 2010 at 09:43 AM
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

rizvisa1
Posts
4479
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
May 5, 2022
770
Apr 20, 2010 at 07:22 AM
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
0
Thank You Very Much For Making Rectification In My VBA Code.
Once Again Thanks Thanks..................................................................................................................................

Santosh
0