Code VBA แทรกรูปลงในเซลต่อกันไปเรื่อย ๆ

[tigerwit]

จากไฟล์ที่แนบมา ต้องการแทรรูปภาพลงในเซล (ที่ คลอลัมน์ C) ให้พอดีกับขนาดของเซลต่อลงไปเรื่อย ๆ
โดยดึงรูปภาพที่เก็บไว้ในโฟลเดอร์ให้ตรงตามชื่อรูปภาพที่อยู่ใน คลอลัมน์ B

Code: Select all

Sub insertpicture2()
Dim student_pic As Picture
Dim pic_location As String
Dim student_name As String
For i = 2 To 11

student_name = Worksheets("sheet5").Cells(i, 2).Value
pic_location = "C:\Picture\" & Worksheets("sheet5").Cells(i, 2).Value & ".jpg"

With Worksheets("sheet5").Cells(i, 3).Value
    Set student_pic = ActiveSheet.Pictures.Insert(pic_location)
End With
Next i
'Worksheets("sheet5").Cells(i, 1).Select
End Sub

จะต้องปรับโค๊ดอย่างไรครับ

[snasui]

ตัวอย่าง Code ครับ

Code: Select all

Sub insertpicture2()
    Dim student_pic As Object
    Dim pic_location As String
    Dim student_name As String
    Dim picPath As String
    
    picPath = "C:\Picture\"
    With Worksheets("Sheet5")
        For i = 2 To 11
            student_name = .Cells(i, 2).Value
            pic_location = picPath & student_name & ".jpg"
            
            With .Cells(i, 3)
                .Activate
                Set student_pic = .Parent.Shapes.AddPicture( _
                    Filename:=pic_location, _
                    linktofile:=False, _
                    savewithdocument:=True, _
                    Left:=.Left, _
                    Top:=.Top, _
                    Width:=.Width, _
                    Height:=.Height)
            End With
        Next i
    End With
    'Worksheets("sheet5").Cells(i, 1).Select
End Sub

[tigerwit]

ขอบคุณครับ
ได้ตามต้องการครับ