VBA ดึงรูปภาพ กรณีรูปภาพไม่ได้มีทุกแถวจะมีข้อความขึ้น แก้ไขอย่างไรครับ

[parnseasa]

Code: Select all

Sub ShowPicture()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Sheet1")
Set ra = .Range("B1", .Range("A65536").End(xlUp).Offset(0, 1))
End With
For Each obj In ActiveSheet.Shapes
If Left(obj.Name, 4) = "Pict" Then
obj.Delete
End If
Next obj
For Each r In ra
Set imgIcon = ActiveSheet.Shapes.AddPicture( _
Filename:="D:\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
Width:=r.Width, Height:=r.Height)
Next r
End Sub

[snasui]

กรุณาโพสต์ Code ให้แสดงรูปแบบตัวอักษรของ Code อ่านกฎข้อ 4 และ 5 ด้านบนแล้วทำมาตามนั้นทั้ง 2 ข้อครับ

[parnseasa]

แก้ไขแล้วครับ

[snasui]

ทำตามข้อ 5 แล้วแต่ยังไม่ได้ทำข้อ 4 ครับ

[parnseasa]

2.jpg

[parnseasa]

TEST รูปภาพ.xlsm

[snasui]

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

Code: Select all

'Other code
For Each r In ra
    If r.Offset(0, -1).Value <> "" Then
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
            SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
            Width:=r.Width, Height:=r.Height)
    End If
Next r
'Other code

[parnseasa]

แก้ไขได้แล้วครับ ขอบคุณมากเลยครับ

[parnseasa]

Code: Select all

Sub ShowPicture()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Sheet1")
Set ra = .Range("B1", .Range("A65536").End(xlUp).Offset(0, 1))
End With
For Each obj In ActiveSheet.Shapes
If Left(obj.Name, 4) = "Pict" Then
obj.Delete
End If
Next obj
For Each r In ra
    If r.Offset(0, -1).Value <> "" Then
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
            SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
            Width:=r.Width, Height:=r.Height)
    End If
Next r
End Sub

[parnseasa]

Untitled.jpg

[parnseasa]

TEST รูปภาพ.xlsm

[snasui]

ได้เขียน Code สำหรับการทำงานนั้นมาแล้วหรือไม่ เขียนว่าอย่างไร ทุกคำถามต้องเขียนมาเองก่อน ที่โพสต์มาคือ Code เดิมเท่านั้นครับ

[parnseasa]

Code: Select all

Sub ShowPicture()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Sheet1")
Set ra = .Range("B1", .Range("A65536").End(xlUp).Offset(0, 1))
End With
For Each obj In ActiveSheet.Shapes
If Left(obj.Name, 4) = "Pict" Then
obj.Delete
End If
Next obj
For Each r In ra
    If r.Offset(0, -1).Value <> "" Then
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
            SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
            Width:=r.Width, Height:=r.Height)
    End If
Next r
End Sub

[snasui]

กรุณาอ่านโพสต์ #12 viewtopic.php?p=114736#p114735 ผมเขียนไว้ชัดเจนแล้ว ไม่โพสต์ Code เดิม ๆ ที่ยังไม่มีการปรับปรุงใด ๆ เพื่อจัดการกับปัญหาล่าสุดที่ถามมาครับ