- Joined
- Aug 5, 2010
- Messages
- 1
- Reaction score
- 0
Dear Expert,
I am using below written VBA code to import jpg file in an excel file against file name from a image folder and its working but few days back my format have been changed.
In the previous format file names were in a column B where range was B5:B2000 and the image were coming in column A where its range was A5:A2000.
In the new format I have to insert/import image (jpg file) against file after every 22 cells (down),the file name will be in column C where is range will be C5:C5000 & image need to be in column A where its range will be A1:A5000.
Request you to please make the rectification in the below written code as per my requirement.
[font='Tahoma','sans-serif']Any help will be highly appreciated. [/font]
[font='Tahoma','sans-serif'][/font]
[font='Tahoma','sans-serif']Best Regards[/font]
[font='Tahoma','sans-serif'][/font]
[font='Tahoma','sans-serif']Santosh [/font]
Existing VBA CODE
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 = "Not Available"
End If
Next
End Sub
I am using below written VBA code to import jpg file in an excel file against file name from a image folder and its working but few days back my format have been changed.
In the previous format file names were in a column B where range was B5:B2000 and the image were coming in column A where its range was A5:A2000.
In the new format I have to insert/import image (jpg file) against file after every 22 cells (down),the file name will be in column C where is range will be C5:C5000 & image need to be in column A where its range will be A1:A5000.
Request you to please make the rectification in the below written code as per my requirement.
[font='Tahoma','sans-serif']Any help will be highly appreciated. [/font]
[font='Tahoma','sans-serif'][/font]
[font='Tahoma','sans-serif']Best Regards[/font]
[font='Tahoma','sans-serif'][/font]
[font='Tahoma','sans-serif']Santosh [/font]
Existing VBA CODE
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 = "Not Available"
End If
Next
End Sub