เพื่อมุ่งให้เกิดคุณภาพจากการอบรมสูงสุด Excel Expert Training ให้การอบรม Excel กลุ่มเล็กๆ ไม่เกิน 6 คนทุกคนสามารถเรียนรู้ Excel อย่างใกล้ชิด จะมาคนเดียวหรือมาเป็นกลุ่มแล้วนัดวันอบรมแบบส่วนตัวก็ได้ ผู้เข้าอบรมทุกคนสามารถติดตามเนื้อหาที่อบรมได้อย่างชัดเจนจากจอภาพด้านหน้าของตัวเอง
Page 5 of 7 FirstFirst ... 34567 LastLast
Results 41 to 50 of 65

Thread: ให้VBAหาภาพในfoldersและใส่ภาพในไฟล์excelอัตโนมัติ

  1. #41
    widtara
    Guest

    การรวม code เก่า กับ code ใหม่เข้าหากัน

    Quote Originally Posted by อรวีร์ View Post
    Code:
    Sub RenameInFolder(ByVal FD As String)
    Dim FN As String, FileList() As String
    Dim I As Integer, J As Integer, Temp As String
    Dim MinFN1 As String, MinFN2 As String
    If Right(FD, 1) <> "\" Then FD = FD & "\"
    FN = Dir(FD & "*.JPG")
    Do While Len(FN) > 0
        ReDim Preserve FileList(I)
        FileList(I) = FN
        FN = Dir()
        I = I + 1
    Loop
    If I < 3 Then
        MsgBox FD & " only " & I & " files"
        Exit Sub
    End If
    For I = 0 To UBound(FileList) - 1
        For J = 1 To UBound(FileList)
            If FileList(I) > FileList(J) Then
                Temp = FileList(I)
                FileList(I) = FileList(J)
                FileList(J) = Temp
            End If
        Next
    Next
    Name (FD & FileList(1)) As (FD & "1.JPG")
    Name (FD & FileList(2)) As (FD & "2.JPG")
    End Sub
    วิธีเรียกใช้
    RenameInFolder "R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD\wk26\RJ LT\105980"
    อย่าลืม Backup file ก่อนทดลองนะคะ
    การรวม code เก่า กับ code ใหม่เข้าหากัน ต้องแยกเข้าไปหรือว่าให้ใช้ code ใหม่เลยอย่างเดียวค่ะ

    Code เก่าที่ใช้อยู่ แต่ต้องเปลี่ยนภาพให้มี 1.jpg และ 2.jpg
    Sub Macro1()
    Dim i As Integer
    For i = 1 To ThisWorkbook.Worksheets.Count
    ThisWorkbook.Worksheets(i).Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("o4").Value & Range("j13").Value & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
    Range("c43").Select
    Selection.FormulaR1C1 = "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"
    On Error Resume Next
    With ActiveSheet.Pictures.Insert(Selection.Value)
    .Top = Range("f55:j86").Top
    .Left = Range("f55:j86").Left
    If .Height > .Width Then
    .Height = Range("f55:j80").Height
    Else
    .Width = Range("f55:j80").Width
    End If
    End With
    Range("l43").Select
    Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"
    With ActiveSheet.Pictures.Insert(Selection.Value)
    .Top = Range("m55:s86").Top
    .Left = Range("m55:s86").Left
    If .Height > .Width Then
    .Height = Range("m55:s86").Height
    Else
    .Width = Range("m55:s86").Width
    End If
    End With
    Application.DisplayAlerts = False
    ActiveWorkbook.Close True
    Next i
    End Sub

  2. #42
    potetae007
    Guest

    เพิ่มเติม...

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

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

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Selection.Row() < 10 Then Exit Sub
    Dim i As Integer
    Dim a, p, b As String
    p = "P:\Package\" =>>>เป็นที่อยู่รูปครับ
    i = Selection.Row()
    a = p + Sheet1.Cells(i, 3).Text + ".jpg"
    b = p + "P000000.jpg"
    On Error GoTo Y
    ActiveSheet.Shapes("Text Box 5").Select
    Selection.ShapeRange.Fill.UserPicture a
    GoTo X
    Y:
    ActiveSheet.Shapes("Text Box 5").Select
    Selection.ShapeRange.Fill.UserPicture "P:\Package\P000000.jpg"
    X:
    Sheet1.Cells(i, 3).Select
    End Sub

  3. #43
    potetae007
    Guest

    ขอโทษครับ

    ขอโทษครับเนื่องจาก File มีขนาดใหญ่ ไม่สามารถ Upload ได้ผมขอแนบ File รูปตัวอย่างแทนนะครับ

  4. #44
    widtara
    Guest

    Question ยังไม่ได้ค่ะ

    Quote Originally Posted by potetae007 View Post
    ขอโทษครับเนื่องจาก File มีขนาดใหญ่ ไม่สามารถ Upload ได้ผมขอแนบ File รูปตัวอย่างแทนนะครับ
    ยังงงกับ code ที่ให้มาค่ะ ทั้ง 2 code ตัวอย่าง คือที่อ้อยเข้าใจตอนนี้นะค่ะ ให้ดูที่ code เก่าของอ้อยนะค่ะ มันใช้งานได้ดี แต่ติดปัญหาเรื่องการไปดึงเอารูปภาพ ซึ่งชื่อรูปภาพของเราไม่ตายตัวเนื่องจากถ่ายมาจากกล้องเลย

    แต่ที่มีข้อสังเกตุให้คือว่า DSC07932 รูปแบบของชื่อจะเป็นแบบนี้ค่ะ
    1.มีตัวอักษรคือ DSC อยู่ ถัดมาจะเป็น ตัวเลข 5 ตัว แต่ละ Folders จะมีภาพอยู่ 3 ถึง 4 ภาพ
    2.ที่ต้องการให้ค้นหาภาพที่มี ลักษณะ อักษร 3 ตัว ตัวเลข 5 ตัวนั้น ตัวเลขท้ายๆที่มีค่าน้อยสุดไม่ต้องการภาพนั้น
    3.ต้องการภาพที่มีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 1 และอันดับ 2 ค่ะ

    ส่วนที่น่าจะต้องแก้ไข code น่าจะอยู่ช่วงนี้ค่ะ

    ช่วงดึงภาพที่ 1 หรือภาพที่มีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 1
    Range("c43").Select
    Selection.FormulaR1C1 = "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"
    On Error Resume Next


    ช่วงดึงภาพที่ 2 หรือภาพที่มีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 2

    Range("l43").Select
    Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"


    โดยส่วนของ Selection.FormulaR1C1 อ่านจากข้อมูลใน sheet ดังนี้ค่ะ

    ที่อยู่นี้จะเปลี่ยนไปเราใช้สูตร =D114&"\"&D115&"\"&D116&"\"&D117&"\"&D118&"\"&$D$119
    ได้เป็น R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk25\RJ ID\96710\1.jpg
    มาเขียนไว้ที่ C43 ที่ sheet นั้นๆเพื่อดึงภาพแรก


    ที่อยู่นี้จะเปลี่ยนไปเราใช้สูตร =D114&"\"&D115&"\"&D116&"\"&D117&"\"&D118&"\"&$D$120
    ได้เป็น R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk25\RJ ID\96710\2.jpg
    มาเขียนไว้ที่ L43 ที่ sheet นั้นๆเพื่อดึงภาพที่ 2



    R:\SQA DEDUCT PAYMENT Y11
    EVENT PICTURES DRYER
    wk25 ="wk"&TEXT(WEEKNUM(P9,16),"00")
    RJ ID
    96710
    1.jpg
    ต้องไปกำหนดชื่อภาพใน Folders ให้มีชื่อเป็น 1
    ภาพเดิมมีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 1 เช่น DSC079323

    2.jpg =D121 ต้องไปกำหนดชื่อภาพใน Folders ให้มีชื่อเป็น 2
    ภาพเดิมมีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 2 เช่น DSC07934


    ตัวอย่างจากจำนวนภาพ ซึ่งชื่อภาพจะเปลี่ยนไปเรื่อยๆเพราะถ่ายภาพใหม่ แต่ละอาทิตย์มีจำนวนภาพที่เยอะ เป็น 500 ภาพขึ้น ถ้ามานั่ง Rename เป็น 1 และ 2 ทุก Folders ส่วนนี้ค่ะ ที่ไม่ไหว
    DSC07932
    DSC07933
    DSC07934

    พอจะเข้าใจไหมค่ะ คืออ้อยก็อธิบายไม่เก่งค่ะ



  5. #45
    excel_fever
    Guest
    Quote Originally Posted by widtara View Post
    1.jpg ต้องไปกำหนดชื่อภาพใน Folders ให้มีชื่อเป็น 1
    ภาพเดิมมีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 1 เช่น DSC079323

    2.jpg =D121 ต้องไปกำหนดชื่อภาพใน Folders ให้มีชื่อเป็น 2
    ภาพเดิมมีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 2 เช่น DSC07934
    แน่ใจได้อย่างไรครับ ว่าหมายเลขของภาพจะต่อเนื่องกันทุกครั้ง
    ลอง
    เซลล์ D119 กรอกชื่อภาพ DSC079323.jpg
    เซลล์ D120 กรอกชื่อภาพ DSC079324.jpg
    ไม่ง่ายกว่าหรือครับ

  6. #46
    widtara
    Guest

    Wink การเรียงกันของเลขภาพแน่ใจค่ะ

    Quote Originally Posted by excel_fever View Post
    แน่ใจได้อย่างไรครับ ว่าหมายเลขของภาพจะต่อเนื่องกันทุกครั้ง
    ลอง
    เซลล์ D119 กรอกชื่อภาพ DSC079323.jpg
    เซลล์ D120 กรอกชื่อภาพ DSC079324.jpg
    ไม่ง่ายกว่าหรือครับ
    มีตัวอย่างให้ดูค่ะ
    R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES FRONT LOAD\wk20

    แค่ตัวอย่าง week 20 week เดียวค่ะ

    เลขจะเรียงลักษณะนี้ค่ะ เลขอาจไม่ซ้ำกันแต่รูปแบบการถ่ายภาพ การจัดเรียงของภาพแน่นอนค่ะ :yesnod:

  7. #47
    อรวีร์
    Guest

    Smile

    ทดลอง Run Code ของอรวีร์หรือยังคะ
    อรวีร์อ่านคำถามของคุณหลังสุดก่อนที่อรวีร์จะเขียน Code นั้น และเข้าใจว่าคุณหมายความดังนี้ค่ะ
    1. มีรูปอยู่ใน Folder หนึ่งๆ(ถ้ามีหลาย Folder ก็วน Loop เอา) เป็นแฟ้มนามสกุล .JPG หลายๆรูป
    2. อาจมีแฟ้มนามสกุลอื่นๆด้วยแต่ไม่สนใจ(เช่น Thumbs.db)
    3. จัดเรียงชื่อแฟ้ม .JPG นั้นๆจากน้อยไปหามาก
    4. เปลี่ยนชื่อแฟ้มที่น้อยสุดอันดับที่ 2 เป็นชื่อ 1.JPG
    5. เปลี่ยนชื่อแฟ้มที่น้อยสุดอันดับที่ 3 เป็นชื่อ 2.JPG
    ----------------------------------------
    Code ข้างบนนั้นของอรวีร์ก็เขียนเพื่อเปลี่ยนชื่อแฟ้มตามขั้นตอน 3. ถึง 5. ข้างบนค่ะ
    โดยถ้าต้องการเปลี่ยนชื่อแฟ้มใน Folder D:\TEM ตามเงื่อนไข(เป็น 1.JPG , 2.JPG) ก็เขียน Code
    RenameInFolder "D:\TEM"
    โปรแกรมจะไปทำขั้นตอน 3. 4. 5. เองค่ะ
    ถ้าชื่อ Folder อยู่ใน Cell D2 ก็ใช้ Code
    RenameInFolder Cells( 2 , 4 ).Value
    หลังจากเปลี่ยนชื่อแฟ้มแล้ว คุณก็เขียน Code เรียกเปิดแฟ้มชื่อ 1.JPG และ 2.JPG ได้เลยค่ะ
    เช่น ถ้าใน D:\TEM มีแฟ้ม
    DSC079323.JPG
    DSC079325.JPG
    DSC079313.JPG
    DSC079341JPG
    Thumbs.db
    ......................
    หลังจากใช้คำสั่ง
    RenameInFolder "D:\TEM"
    โปรแกรมจะเรียงแฟ้ม .JPG แล้วพบว่าชื่อน้อยสุดคือ DSC079313.JPG จะไม่ทำอะไรค่ะ
    ชื่อแฟ้มน้อยอันดับสองคือ DSC079323.JPG จะเปลี่ยนชื่อแฟ้มนี้เป็น 1.JPG
    ชื่อแฟ้มน้อยอันดับสามคือ DSC079325.JPG จะเปลี่ยนชื่อแฟ้มนี้เป็น 2.JPG
    สรุปคือหลัง Run โปรแกรม รายชื่อแฟ้มใน D:\TEM จะเป็น
    1.JPG
    2.JPG
    DSC079313.JPG
    DSC079341JPG
    Thumbs.db

  8. #48
    อรวีร์
    Guest

    Smile

    โปรแกรมที่เปลี่ยนชื่อแฟ้มใน Folder ใดๆต้อง Run ครั้งเดียวนะคะ
    เพราะชื่อแฟ้มได้เปลี่ยนไปแล้ว ถ้า run อีก แฟ้มน้อยสุดจะเป็น 1.JPG และน้อยอันดับสองจะเป็น 2.JPG ซึ่งทั้งสองไม่ควรเปลี่ยนชื่ออีกค่ะ

  9. #49
    widtara
    Guest

    เข้าใจความหมายแล้วค่ะ

    Quote Originally Posted by อรวีร์ View Post
    โปรแกรมที่เปลี่ยนชื่อแฟ้มใน Folder ใดๆต้อง Run ครั้งเดียวนะคะ
    เพราะชื่อแฟ้มได้เปลี่ยนไปแล้ว ถ้า run อีก แฟ้มน้อยสุดจะเป็น 1.JPG และน้อยอันดับสองจะเป็น 2.JPG ซึ่งทั้งสองไม่ควรเปลี่ยนชื่ออีกค่ะ
    รันแล้วแต่ไม่ได้ผลค่ะ เขาทำงานเฉพาะคำสั่งเก่าของอ้อย เมื่อไม่เจอภาพ 1 และ 2 ก็แยกให้เฉพาะ sheet เปล่าๆมาให้ค่ะ
    อ้อยวาง code เรียบร้อยแล้ว ช่วยดูให้หน่อยนะค่ะ:yesnod:


    Sub RenameInFolder(ByVal FD As String)
    Dim FN As String, FileList() As String
    Dim I As Integer, J As Integer, Temp As String
    Dim MinFN1 As String, MinFN2 As String
    If Right(FD, 1) <> "\" Then FD = FD & "\"
    FN = Dir(FD & "*.JPG")
    Do While Len(FN) > 0
    ReDim Preserve FileList(I)
    FileList(I) = FN
    FN = Dir()
    I = I + 1
    Loop
    If I < 3 Then
    MsgBox FD & " only " & I & " files"
    Exit Sub
    End If
    For I = 0 To UBound(FileList) - 1
    For J = 1 To UBound(FileList)
    If FileList(I) > FileList(J) Then
    Temp = FileList(I)
    FileList(I) = FileList(J)
    FileList(J) = Temp
    End If
    Next
    Next
    Name (FD & FileList(1)) As (FD & "1.JPG")
    Name (FD & FileList(2)) As (FD & "2.JPG")
    End Sub

    Sub Macro1()
    Dim I As Integer
    For I = 1 To ThisWorkbook.Worksheets.Count
    ThisWorkbook.Worksheets(I).Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("o4").Value & Range("j13").Value & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
    Range("c43").Select
    Selection.FormulaR1C1 = "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"
    On Error Resume Next
    With ActiveSheet.Pictures.Insert(Selection.Value)
    .Top = Range("f55:j86").Top
    .Left = Range("f55:j86").Left
    If .Height > .Width Then
    .Height = Range("f55:j80").Height
    Else
    .Width = Range("f55:j80").Width
    End If
    End With

    Range("l43").Select
    Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"

    With ActiveSheet.Pictures.Insert(Selection.Value)
    .Top = Range("m55:s86").Top
    .Left = Range("m55:s86").Left
    If .Height > .Width Then
    .Height = Range("m55:s86").Height
    Else
    .Width = Range("m55:s86").Width
    End If
    End With

    Application.DisplayAlerts = False
    ActiveWorkbook.Close True
    Next I
    End Sub

  10. #50
    อรวีร์
    Guest

    Smile

    เท่าที่ดู Code ของคุณ ยังไม่มีคำสั่งส่วนที่เรียกโปรแกรมของอรวีร์เลยนี่คะ
    ฉะนั้นชื่อแฟ้มยังไม่ได้เปลี่ยน ทำให้จะไม่พบ 1.JPG , 2.JPG ค่ะ

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •