1 click to insert all Photos to different columns

annievn

New Member
Joined
Aug 1, 2021
Messages
8
Office Version
  1. 2016
Platform
  1. Windows
I'm using this code to add photos based on folder image name and this worked fine but i want to insert image to more than 1 columns. There is any ways to do it? Hope you guys can help me. For example my picname value on columns A; C; E and my pic pasthere value on columns B; D; F ... how can i do it?
EXCEL-insert photos to many columns.jpg

VBA Code:
Sub InsertAllPicture()
Dim pictname As String
Dim pastehere As Range
Dim pasterow As Long
Dim x As Long
Dim lastrow As Long, cPic

lastrow = Worksheets("sheet1").Range("A3").CurrentRegion.Rows.Count
x = 3
For x = 3 To lastrow
    Set pastehere = Cells(x, 6)
    pasterow = pastehere.Row
    Cells(pasterow, 6).Select 'This is where picture will be inserted
    pictname = Cells(x, 5) 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture("D:\O 3\SAM PHAM BAN\PRODUCTS POST\Product Insert PR SKU\" & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
    With cPic
        .LockAspectRatio = msoFalse
        .Height = 80#
        .Width = 80#
        .Left = Cells(pasterow, 6).Left + Cells(pasterow, 1).Width / 2 - .Width/2
        .Top = Cells(pasterow, 6).Top + Cells(pasterow, 1).Height / 2 - .Height/2
    End With
Next x
Set cPic = Nothing
End Sub
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,268
Keeping the structure of the previous macro:
VBA Code:
Sub InsertAllPicture()
Dim pictname As String
Dim pastehere As Range
Dim lastrow As Long, cPic
Dim myC As Range, picPath As String, ckCols As String
'
ckCols = "A3:F3"                                    '<<< Address of the first row
picPath = "D:\DImmagini\"                           '<<< Your pictures path + \
'
Sheets("sheet1").Select
lastrow = Range(ckCols).Resize(1000).Find(What:="*", After:=Range(ckCols).Cells(1, 1), _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious).Row
For Each myC In Range(ckCols).Resize(lastrow)
If myC.Value <> "" Then
    Set pastehere = myC.Offset(0, 1)
    pastehere.Select 'This is where picture will be inserted
    pictname = myC.Value 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture(picPath & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
    With cPic
        .LockAspectRatio = msoFalse
        .Height = 80#
        .Width = 80#
        .Left = pastehere.Left + pastehere.Width / 2 - .Width / 2
        .Top = pastehere.Top + pastehere.Height / 2 - .Height / 2
    End With
End If
Next myC
Set cPic = Nothing
End Sub

Compile the two rows marked <<< with your information

Bye
 
Solution

annievn

New Member
Joined
Aug 1, 2021
Messages
8
Office Version
  1. 2016
Platform
  1. Windows
Keeping the structure of the previous macro:
VBA Code:
Sub InsertAllPicture()
Dim pictname As String
Dim pastehere As Range
Dim lastrow As Long, cPic
Dim myC As Range, picPath As String, ckCols As String
'
ckCols = "A3:F3"                                    '<<< Address of the first row
picPath = "D:\DImmagini\"                           '<<< Your pictures path + \
'
Sheets("sheet1").Select
lastrow = Range(ckCols).Resize(1000).Find(What:="*", After:=Range(ckCols).Cells(1, 1), _
              SearchOrder:=xlByRows, _
              SearchDirection:=xlPrevious).Row
For Each myC In Range(ckCols).Resize(lastrow)
If myC.Value <> "" Then
    Set pastehere = myC.Offset(0, 1)
    pastehere.Select 'This is where picture will be inserted
    pictname = myC.Value 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture(picPath & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
    With cPic
        .LockAspectRatio = msoFalse
        .Height = 80#
        .Width = 80#
        .Left = pastehere.Left + pastehere.Width / 2 - .Width / 2
        .Top = pastehere.Top + pastehere.Height / 2 - .Height / 2
    End With
End If
Next myC
Set cPic = Nothing
End Sub

Compile the two rows marked <<< with your information

Bye
I have been search for it many days with no results. You are my hero! Thank you for your help! Your code worked so good but I had trying some more with add more other value to next columns then i got this error...
EXCEL-insert photos to many columns2.jpg
 

Anthony47

Well-known Member
Joined
Mar 29, 2006
Messages
2,268
VBA Code:
    pictname = myC.Value 'This is the picture name
    Set cPic = ActiveSheet.Shapes.AddPicture(picPath & pictname & ".jpg", False, True, PosizLeft, PositTop, True, True)
The macro assumes that the picture is in a local directory (picPath) and the cell contains the name of the file; you are trying to use a full name for a web hosted picture.
To deal with this condition, replace the two mentioned instructions with these:
VBA Code:
    If Left(myC.Value, "4") = "http" Then
        pictname = myC.Value
    Else
        pictname = picPath & myC.Value & ".jpg"
    End If
    Set cPic = ActiveSheet.Shapes.AddPicture(pictname, False, True, PosizLeft, PositTop, True, True)
Bye
 

annievn

New Member
Joined
Aug 1, 2021
Messages
8
Office Version
  1. 2016
Platform
  1. Windows
The macro assumes that the picture is in a local directory (picPath) and the cell contains the name of the file; you are trying to use a full name for a web hosted picture.
To deal with this condition, replace the two mentioned instructions with these:
VBA Code:
    If Left(myC.Value, "4") = "http" Then
        pictname = myC.Value
    Else
        pictname = picPath & myC.Value & ".jpg"
    End If
    Set cPic = ActiveSheet.Shapes.AddPicture(pictname, False, True, PosizLeft, PositTop, True, True)
Bye
Sorry for reply late Anthony! I was busy to do so many work, today i applied your code to my excel file and that worked!! Thank you. Have a good day!😘
 

Forum statistics

Threads
1,147,635
Messages
5,742,250
Members
423,717
Latest member
rubthenut

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top