ไฟล์ ดึงรูป Error

[trirongcop]

Test pic.xlsm

สอบถามครับ ใช้สูตร Macro ด้านล่างในการดึงรูปมาโชว์ แต่ติดปัญหา Run แล้ว Error เนื่องจากมีการ Update Microsoft vison ใหม่
ตัวอย่าง สูตรตามด้านล่างจะปรับแบบไหนได้บ้าง ครับ


Sub Macro1()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Pic")
Set ra = .Range("A2", .Range("b1500").End(xlUp).Offset(0, 0))
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:="T:\Office\Bow\ItemsPic\" & r.Offset(0, 1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
Width:=r.Width - 1, Height:=r.Height)
Next r
End Sub

ตัวอย่าง ไฟล์ Error ในเอกสารแนบ ครับ

[snasui]

กรุณาปรับการโพสต์ Code ให้แสดงเป็นตัวอักษรแบบ Code ดูตัวอย่างในกฎการใช้บอร์ดข้อ 5 ด้านบนประกอบครับ

[trirongcop]

Code: Select all

Sub Macro1()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Pic")
Set ra = .Range("A2", .Range("b1500").End(xlUp).Offset(0, 0))
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:="T:\Office\Bow\ItemsPic\" & r.Offset(0, 1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
Width:=r.Width - 1, Height:=r.Height)
Next r
End Sub

[snasui]

หากต้องการวางรูปในคอลัมน์ A การกำหนดค่าให้ตัวแปร ra ควรเป็น Set ra = .Range("A2", .Range("b1500").End(xlUp).Offset(0, -1)) ครับ

ควรจับภาพปัญหามาด้วยจะได้เข้าถึงปัญหาโดยเร็วครับ

[trirongcop]

อาจารย์ ครับ ถ้าเกิดจากการที่เครื่องคอมมีการ update Microsoft version ใหม่ ควรปรับแก้ไข หรือเพิ่มเติม code VBA ไปในทิศทางไดได้บ้าง ครับ

[puriwutpokin]

ThisWorkbook.Activate ลองใส่ตัวนี้ดูครับว่าจะได้ไหม

Code: Select all

Sub Macro1()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Pic")
Set ra = .Range("A2", .Range("b1500").End(xlUp).Offset(0, 0))
End With
For Each obj In ActiveSheet.Shapes
If Left(obj.Name, 4) = "Pict" Then
obj.Delete
End If
Next obj
ThisWorkbook.Activate  'ลองใส่ตัวนี้ดูครับว่าจะได้ไหม
For Each r In ra
Set imgIcon = ActiveSheet.Shapes.AddPicture( _
Filename:="T:\Office\Bow\ItemsPic\" & r.Offset(0, 1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
Width:=r.Width - 1, Height:=r.Height)
Next r
End Sub

[trirongcop]

อาจาร์ย ครับ run แล้วยังไม่ได้ครับ แต่ขึ้น Error หน้าต่างนี้เหมือนเดิม ต้องกด OK จนถึงแถวสุดท้ายรูปถึงจะขึ้นครับ
ตัวอย่างข้อความและ Code BVA ที่ error ครับ

[puriwutpokin]

ปรับตามนี้ครับ

Code: Select all

Sub Macro1()
    Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
    With Worksheets("Pic")
        Set ra = .Range("A2:A" & .Range("b1500").End(xlUp).Row)
    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:="T:\Office\Bow\ItemsPic\" & r.Offset(0, 1) & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
        Width:=r.Width - 1, Height:=r.Height)
    Next r
End Sub

[trirongcop]

อาจารย์ ครับ ปรับสูตรได้ผลลัพธ์ถูกต้อง แต่ถ้าจะเพิ่มรูปให้เพิ่มอีก Columns ข้างๆกันปรับเพิ่มได้ไหมครับ
ผลลองปรับ

Code: Select all

Range("B1500:F1500")[code] แต่ไม่ได้ครับ

[puriwutpokin]

ปรับตามนี้ครับ

Code: Select all

Sub AddPics()
    Dim r As Range, ra As Range
    Dim imgIcon As Object
    Dim obj As Object
    On Error Resume Next
    With Worksheets("Pic")
        Set ra = .Range("A2:A" & .Range("b1500").End(xlUp).Row)
        Set rb = .Range("E2:E" & .Range("f1500").End(xlUp).Row)
    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 Union(ra, rb)
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="T:\Office\Bow\ItemsPic\" & r.Offset(0, 1) & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
        Width:=r.Width - 1, Height:=r.Height)
    Next r
End Sub

[trirongcop]

ขอบคุณอาจารย์มากครับจะนำไปปรับใช้ให้ประโยชน์ให้มากที่สุดครับ

[trirongcop]

อาจารย์ ครับ สอบถามเพิ่มเติมหน่อยครับ ถ้า Number ไหนที่ไม่มีอยู่ใน ฐาน Data สูตรแจ้ง Error ขึ้น ปรับให้ค้นหาข้ามแล้วให้เป็น ช่องว่างพอจะได้ไหมครับ
ตัวอย่าง Error ที่มีอักษรอื่นที่ไม่มีในฐาน Data ครับ

Error 2.jpg

[puriwutpokin]

ปรับตามนี้ครับ

Code: Select all

Sub AddPics()
    Dim r, ra, rb As Range
    Dim imgIcon, obj As Object
    Dim PicFile As String
    On Error Resume Next
    With Worksheets("Pic")
        Set ra = .Range("A2:A" & .Range("b1500").End(xlUp).Row)
        Set rb = .Range("E2:E" & .Range("f1500").End(xlUp).Row)
    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 Union(ra, rb)
        PicFile = "T:\Office\Bow\ItemsPic\" & r.Offset(0, 1) & ".jpg"
        If Dir(PicFile) <> vbNullString Then
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:=PicFile, LinkToFile:=False, _
        SaveWithDocument:=True, Left:=r.Left + 1, Top:=r.Top, _
        Width:=r.Width - 1, Height:=r.Height)
     End If
    Next r
End Sub

[trirongcop]

ขอบคุณครับอาจารย์ ไม่ Error แล้วครับ