1 click to insert all Photos to different columns

[annievn]

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?

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

 

[Anthony47]

Keeping the structure of the previous macro:

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

 

[annievn]

Keeping the structure of the previous macro:

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...

 

[Anthony47]

    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:

    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]

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:

    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!?

 

[Anthony47]

Thanks for the feedback