Page 1 of 1
ไฟล์ ดึงรูป Error
Posted: Tue May 03, 2022 2:22 pm
by 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 ในเอกสารแนบ ครับ
Re: ไฟล์ ดึงรูป Error
Posted: Tue May 03, 2022 9:37 pm
by snasui
กรุณาปรับการโพสต์ Code ให้แสดงเป็นตัวอักษรแบบ Code ดูตัวอย่างในกฎการใช้บอร์ดข้อ 5 ด้านบนประกอบครับ
Re: ไฟล์ ดึงรูป Error
Posted: Wed May 04, 2022 8:54 am
by 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
Re: ไฟล์ ดึงรูป Error
Posted: Wed May 04, 2022 8:15 pm
by snasui
หากต้องการวางรูปในคอลัมน์ A การกำหนดค่าให้ตัวแปร
ra ควรเป็น
Set ra = .Range("A2", .Range("b1500").End(xlUp).Offset(0, -1)) ครับ
ควรจับภาพปัญหามาด้วยจะได้เข้าถึงปัญหาโดยเร็วครับ
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 1:26 pm
by trirongcop
อาจารย์ ครับ ถ้าเกิดจากการที่เครื่องคอมมีการ update Microsoft version ใหม่ ควรปรับแก้ไข หรือเพิ่มเติม code VBA ไปในทิศทางไดได้บ้าง ครับ
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 2:10 pm
by 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
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 3:18 pm
by trirongcop
อาจาร์ย ครับ run แล้วยังไม่ได้ครับ แต่ขึ้น Error หน้าต่างนี้เหมือนเดิม ต้องกด OK จนถึงแถวสุดท้ายรูปถึงจะขึ้นครับ
ตัวอย่างข้อความและ Code BVA ที่ error ครับ
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 4:20 pm
by 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
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 4:50 pm
by trirongcop
อาจารย์ ครับ ปรับสูตรได้ผลลัพธ์ถูกต้อง แต่ถ้าจะเพิ่มรูปให้เพิ่มอีก Columns ข้างๆกันปรับเพิ่มได้ไหมครับ
ผลลองปรับ
Code: Select all
Range("B1500:F1500")[code] แต่ไม่ได้ครับ
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 5:07 pm
by 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
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 5:28 pm
by trirongcop
ขอบคุณอาจารย์มากครับจะนำไปปรับใช้ให้ประโยชน์ให้มากที่สุดครับ
Re: ไฟล์ ดึงรูป Error
Posted: Thu May 05, 2022 6:15 pm
by trirongcop
อาจารย์ ครับ สอบถามเพิ่มเติมหน่อยครับ ถ้า Number ไหนที่ไม่มีอยู่ใน ฐาน Data สูตรแจ้ง Error ขึ้น ปรับให้ค้นหาข้ามแล้วให้เป็น ช่องว่างพอจะได้ไหมครับ
ตัวอย่าง Error ที่มีอักษรอื่นที่ไม่มีในฐาน Data ครับ
Error 2.jpg
Re: ไฟล์ ดึงรูป Error
Posted: Fri May 06, 2022 7:54 am
by 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
Re: ไฟล์ ดึงรูป Error
Posted: Fri May 06, 2022 2:21 pm
by trirongcop
ขอบคุณครับอาจารย์ ไม่ Error แล้วครับ