สอบถามต้องการแสดงรูปตามช่วงที่กำหนด VBA

[titus]

สอบถามต้องการแสดงรูปตามช่วงที่กำหนด ก่อนแสดงรูปให้ลบรูปเก่าก่อนแสดง

Code: Select all

Sub ShowPicture()
Dim r As String
Dim imgIcon
On Error Resume Next
    ActiveSheet.Shapes(1).Delete
r = Range("AA1").Value
With Range("Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278")
    Set imgIcon = ActiveSheet.Shapes.AddPicture( _
    Filename:="D:\1.pic\" & r & ".jpg", LinkToFile:=False, _
    SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
    Width:=344, Height:=253)
End With
Set imgIcon = Nothing
End Sub

ต้องการแสดงช่วง Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278 แต่พแรันแล้วมันจะแสดงแค่ Q17 ครับ

[snasui]

แนบไฟล์ตัวอย่างมาด้วยจะได้สะดวกในการทดสอบของเพื่อน ๆ ในการช่วยตอบครับ

[titus]

ขอโทษครับลืมแนบไฟล

[logic]

ลองประยุกตุ์ดูครับ

Code: Select all

On Error Resume Next
For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 3) = "Pic" Then
        shp.Delete
    End If
Next shp
r = Range("AA1").Value
For Each Rng In Range("Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278")
    With Rng
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\1.pic\" & r & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
        Width:=344, Height:=253)
    End With
Next Rng
Set imgIcon = Nothing

[titus]

ได้ลองประยุกต์ ดูแล้วครับติดปัญหา
1ค่าของ Call AA1 พอกด enter รูปไม่เปลี่ยนตาม แต่ลองกด F8 ลองเทสรันรูปมาครับ
2รูปที่เปลี่ยน ไม่ได้รบรูปเก่าครับ เอารูปใหม่ไปทับเลย

[titus]

โค๊ดตัวนี้ เช็คค่าการเปลี่ยนแปลง ของ AA1 อยู่ใน sheets Form ครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Address = "$AA$1" Then
    Call ShowPicture
End If
Application.EnableEvents = True
End Sub

[snasui]

ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Dim r As String
Dim imgIcon
On Error Resume Next
For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 3) = "pic" Or Left(shp.Name, 3) = "รูป" Then
        shp.Delete
    End If
Next shp
r = Range("AA1").Value
For Each Rng In Range("Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278")
    With Rng
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\1.pic\" & r & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
        Width:=342, Height:=251)
    End With
Next Rng
Set imgIcon = Nothing

ถ้าภาพมีอยู่จริงตาม Folder ทีกำหนดไว้ใน Code จะต้องได้คำตอบครับ

[titus]

ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Dim r As String
Dim imgIcon
On Error Resume Next
For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 3) = "pic" Or Left(shp.Name, 3) = "รูป" Then
        shp.Delete
    End If
Next shp
r = Range("AA1").Value
For Each Rng In Range("Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278")
    With Rng
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\1.pic\" & r & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
        Width:=342, Height:=251)
    End With
Next Rng
Set imgIcon = Nothing

ถ้าภาพมีอยู่จริงตาม Folder ทีกำหนดไว้ใน Code จะต้องได้คำตอบครับ

ลองสูตรแล้วครับ Error ครับ
** ในโฟเดอร์รูป ผมตั้งชื่อรูปให้มีชื่อ ด้านหน้า pic-.... ในการตรวจสอบ ตามสูตร

[titus]

ตอนนี้แก้ไขแล้วครับ ผมลืมใส่ sub และ end sub หาย

ตอนนี้ติดอย่างเดียว รูป ไม่ยอมลบครับ เรียกขึ้นมาทับเลย

[snasui]

รูปมีชื่อว่าอะไรครับ

คลิกที่รูปแล้วดูที่ Name Box (กล่องซ้ายสุดบน Formula Bar) จะเห็นชื่อรูป แจ้งชื่อนั้นมาครับ

[titus]

รูปมีชื่อว่าอะไรครับ

คลิกที่รูปแล้วดูที่ Name Box (กล่องซ้ายสุดบน Formula Bar) จะเห็นชื่อรูป แจ้งชื่อนั้นมาครับ

ชื่อ. รูปภาพ 1.....รูปภาพ 10 ครับ

[titus]

รูป

[logic]

ถ้าขึ้นต้นว่า รูป หรือ Pic โค้ดที่อาจารย์เขียนให้ทำงานได้แล้วนะครับ

ตัวอย่างการปรับ Code ตามด้านล่างครับ

Code: Select all

Dim r As String
Dim imgIcon
On Error Resume Next
For Each shp In ActiveSheet.Shapes
    If Left(shp.Name, 3) = "pic" Or Left(shp.Name, 3) = "รูป" Then
        shp.Delete
    End If
Next shp
r = Range("AA1").Value
For Each Rng In Range("Q17,Q46,Q75,Q104,Q133,Q162,Q191,Q220,Q249,Q278")
    With Rng
        Set imgIcon = ActiveSheet.Shapes.AddPicture( _
        Filename:="D:\1.pic\" & r & ".jpg", LinkToFile:=False, _
        SaveWithDocument:=True, Left:=.Left, Top:=.Top, _
        Width:=342, Height:=251)
    End With
Next Rng
Set imgIcon = Nothing

ถ้าภาพมีอยู่จริงตาม Folder ทีกำหนดไว้ใน Code จะต้องได้คำตอบครับ

ทำ on error resume next ให้เป็น comment ไปก่อน แล้วลองดีบักด้วยการคลิกในโค้ดแล้วกด F8 ซ้ำ ๆ ดูว่าติดบรรทัดไหนจะได้ช่วยกันดูได้ครับ

[titus]

Comment ไปแล้วครับ. ลอง f8 ดูไม่ติด errorนะครับ ผ่านตลอดแต่รูปไม่ลบ งงเลย

[titus]

ผมลองบันทึกมาโครแล้วลบดู code. ออกมาแบบนี้ครับ
Activesheet.Shapes.Range(Array("Picture 10")).select
Selection.Delete

[DhitiBank]

จากโค้ดเดิม
If Left(shp.Name, 3) = "pic"

ลองปรับเป็นแบบนี้ดูครับ
If Ucase(Left(shp.Name, 3)) = "PIC"

[titus]

จากโค้ดเดิม
If Left(shp.Name, 3) = "pic"

ลองปรับเป็นแบบนี้ดูครับ
If Ucase(Left(shp.Name, 3)) = "PIC"

ลองแล้วไม่ลบครับ

[titus]

ได้แล้วครับ. คือ ไปแก้ที่ pic จากพิมพ์เล็กเป็นพิมพ์ใหญ่ ครับ PIC