มีปัญหาดึงภาพ jpg ให้จับแค่ชื่อ 8 ตัวอักษรครับไม่ได้ครับ

[essung]

รบกวนชี้แนะครับ
ปัญหา Excel VBA code ดึงภาพจากเครื่องครับ ถ้าตรวจจับ code 8 หลัก

เนื่องจาก Code รูปบางครั้งมีเกิน 8 หลัก เช่น 214E5963-001 มีรูปกับข้อมูลอยู่แล้ว
บาง Code สินค้า ใน Excel ก็มี 8 - 11 หลักเช่นกัน

**แต่ถ้าชื่อตรงก็จะขึ้นภาพครับ

จุดประสงค์คือ ต้องการให้ โปรแกรม ตัดตัวอักษร(.jpg) แค่ 8 หลัก เพื่อให้รูปทำงานครับ ทั้ง Excel และ JPG มีรหัสต่างจำนวนแต่สามารถดึงรูปได้ เช่น
Code 214E5963-001 ดึง 214E5963.jpg ได้ครับ หรือ 214E5963 0001 ดึง 214E5963-002

ขอบพระคุณอย่างสูงครับ

ทดสอบ code.XLS

[essung]

แทรกไฟล์เพิ่มครับ

[snasui]

ลองดูตัวอย่าง Code ตามด้านล่างครับ ซึ่งจะต้อง Add Reference ที่ชื่อว่า Microsoft Scripting Runtine โดยเข้าเมนู Tools > References

Code ที่ชีท Xinzhou Suibao

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Call Test
End Sub

Code ที่ Module1

Code: Select all

Sub Test()
    Dim SourceFolder As Scripting.Folder
    Dim fso As New Scripting.FileSystemObject
    Dim fName As String, picName As String
    Dim Found As Boolean
    DoEvents
    fName = "C:\"
    Set SourceFolder = fso.GetFolder(fName)
    fName = Dir(SourceFolder.Path & "\*.*")
    Do While fName <> ""
        If Selection.Value = Left(fName, 8) Then
            picName = "C:\" & fName
            Range("A1")(1).Comment.Shape.Fill.UserPicture picName
            Found = True
            Exit Do
        End If
        fName = Dir
    Loop
    If Found = False Then
        MsgBox "Not found"
    End If
End Sub

[wwattana]

อาจารย์ครับ
ผมลองปรังปรุงตามที่อาจารย์แก้ไขมาเพื่อปรับใช้ที่บริษัทแต่ยังไม่สามารถดึงรูปขึ้นมาจาก c:\Promaterial ได้เลยครับ
รบกวนชี้แนะด้วยครับ

[snasui]

ไฟล์ที่จะแนบ Code ได้ต้องเป็นนามสกุล .xlsm ครับ แนบไฟล์พร้อม Code ที่ลองเขียนเองมาใหม่ ระบุด้วยว่ามีปัญหาที่ Module ใด Procedure ใดครับ

[wwattana]

กราบขออภัยอย่างสูงครับอาจารย์ ที่ผมไม่อ่าน กฏ-กติกา ที่ภูกต้องก่อนทำการโพสข้อความครับ
สืบเนื่องจากที่บริษัทมีอุปกรณ์ส่งเริมการขายค่อนข้างมาก และเวลาสั่งของก็สั่งกันผิดอยู่บ่อยๆ
เลยมีแนวความคิดว่านำรูปมาโชว์ในเอกสารสั่งของด้วยน่าจะแก้ปัญหาได้ครับ
ผมลองทำตามโค๊ดที่อยู่ในกระทู้นี้ แต่ติดปัญหานิดหนึ่งครับ

พอรันแล้ว ขึ้นว่า
Run-time errer '91':
Object varible or With block varible not set ครับ

ปัญหาคงอยู่ที่ Module1 จุดโชว์รูป ที่ K4 ครับ
รบกวนสอบถามวิธีเซ็ท ให้โชว์ภาพ เมื่อคลิ๊กที่ Colum D ที่เป็นโค๊ดของภาพที่จะดึงจากโฟล์เดอร์ C:\Promaterial\ ครับ
ต้องรบกวนอาจารย์ชีแนะด้วยครับเพราะยังไม่มีความรู้เกี่ยวกับ VB เลยครับ
พอทำได้แค่คำสั่งทั่วๆไปเองครับ

PromattOrder.xlsm

[snasui]

จากตัวอย่างไฟล์ที่แนบมา ลองปรับ Code เป็นตามด้านล่างครับ

Code: Select all

Sub Test()
    Dim SourceFolder As Scripting.Folder
    Dim fso As New Scripting.FileSystemObject
    Dim fName As String, picName As String
    Dim Found As Boolean
    DoEvents
    fName = "C:\Promaterial\"
    Set SourceFolder = fso.GetFolder(fName)
    fName = Dir(SourceFolder.Path & "\*.*")
    Do While fName <> ""
        If Selection.Value = Left(fName, 12) Then
            picName = "C:\Promaterial\" & fName
            Range("L4")(1).Comment.Shape.Fill.UserPicture picName
            Found = True
            Exit Do
        End If
        fName = Dir
    Loop
    If Found = False Then
        
    End If
End Sub

[wwattana]

ทำได้แล้วครับ ผมดูไม่ดีเอง แค่เลื่อนเซลล์ไปเซลล์เดียวเอง รู้สึกละอายใจจริงๆเลยครับ
แต่แก้ปัญหาจุดนี้ได้แล้วก็เจออีกปัญหาหนึ่งครับ
ใน Module 1 เนื่องจากเราสั่งให้ If Selection.Value = Left(fName, 12)
พอเราคลิ๊กที่เซลล์อื่นจะขึ้น error 13 Type Mismach. ครับตรงจุดนี้เราจะแก้ไขอย่างไรดีครับ
ถึงจะไม่ขึ้น error อีกครับเวลาเราคลิ๊กจุดอื่นที่ไม่มี Left(fName, 12)

ขอบพระคุณอย่างสูงครับอาจารย์

[snasui]

ปรับ Code ตามด้านล่างให้ตรวจสอบว่าเซลล์ที่ถูกเลือกคือเซลล์เป้าหมายที่ต้องการหรือไม่ หากใช่ให้ทำงานต่อ หากไม่ใช่ให้หยุดทำงาน

จาก

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Call Test
End Sub

ปรับเป็น

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = $M$4 Then 'ปรับให้เป็นเซลล์ที่ต้องการตรวจสอบ
   Call Test
End If
End Sub

[wwattana]

โปรเกรมขึ้น Syntax Error ครับ

โค๊ด
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = (E12:E42) Then
Call Test
End If
End Sub

ลองใส่ให้ Excel ตรวจสอบ คอลัม E12-E42
แต่โปรเกรมขึ้น Syntax Error ครับ
ลองทั้งแบบ $E$ หรือ E$ , $E ก็ยังใช้ไม่ได้ครับ
คงต้องรบกวนอาจารย์ชี้แนะอีกครั้งครับว่าต้องใส่แบบใหนดีครับ

[snasui]

ผมลืมใส่ฟันหนูครอบครับ

ปรับใหม่เป็น

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$M$4" Then 'ปรับให้เป็นเซลล์ที่ต้องการตรวจสอบ
   Call Test
End If
End Sub

[wwattana]

ยังไม่สำเร็จครับอาจารย์
ผม ใส่ให้ Excel ทำการตรวจสอบ คอลัม E พร้อมใส่ฟันหนูแบบที่อาจารย์ใส่มาแล้วครับ
ไม่มี error ขึ้นมา แต่ คลิ๊กที่ คอลัม E ทั้งคอลัม ไม่มีรูปขึ้นมาเลยครับ
เลยไม่ทราบว่าผมทำตรงไหนผิดอยู่อีก
ผมแนบโค๊ดที่แก้พร้อมไฟล์มาให้อาจารย์ตรวจอีกครั้งครับ

[wwattana]

Sheet01--------------------------------------------------------------------

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$E" Then
Call Test
End If
End Sub

Module1--------------------------------------------------------------------

Sub Test()
Dim SourceFolder As Scripting.Folder
Dim fso As New Scripting.FileSystemObject
Dim fName As String, picName As String
Dim Found As Boolean
DoEvents
fName = "C:\Promaterial\"
Set SourceFolder = fso.GetFolder(fName)
fName = Dir(SourceFolder.Path & "\*.*")
Do While fName <> ""
If Selection.Value = Left(fName, 12) Then
picName = "C:\Promaterial\" & fName
Range("L4")(1).Comment.Shape.Fill.UserPicture picName
Found = True
Exit Do
End If
fName = Dir
Loop
If Found = False Then

End If
End Sub

[wwattana]

Excel+ไฟล์รูปครับ
C:\Promaterial\

[snasui]

การใช้ .Address จะต้องบอกว่าเป็นคอลัมน์ใดและบรรทัดใด จะระบุเป็น "$E" เช่นนี้เพื่อบอกว่าเป็นคอลัมน์ E ไม่ได้ครับ

ถ้าต้องการให้โปรแกรมตรวจสอบว่าต้องเป็นคอลัมน์ E เท่านั้นสามารถใช้การตรวจสอบตามด้านล่างครับ

Code: Select all

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.Column = 5 Then
      Call Test
   End If
End Sub

การวาง Code VBA ในกล่องความเห็นให้ดูตามกระทู้นี้ จะได้สะดวกในการอ่านครับ viewtopic.php?f=3&t=1187

[wwattana]

ใช้งานได้โดยสมบูรณ์ครับ
ได้ความรู้และได้เริ่มเข้าใจ เกี่ยวกับ VB มากขึ้นมากขึ้นเยอะเลยครับ
ขอบคุณท่านอาจารย์มากๆเลยครับที่กรุณาสอนคนที่ไม่ค่อยมีความรู้อย่างผมจนเข้าใจ
จะได้นำไปต่อยอดและนำไปสอนคนอื่นๆได้อีก

ขอบคุณมากๆเลยครับอาจารย์