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

[widtara]

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

[potetae007]

ไม่แน่ใจว่าทำได้หรือยัง แต่ผมอยากเพิ่มเติมครับ ลองเอาตัวอย่างที่ผมใช้งานอยู่ไปประยุกต์ดูนะครับว่าตรงกับที่ต้องการหรือป่าว โดยที่ผมทำคือจะให้ใส่ชื่อก่อน แล้วคลิกเลือกที่ 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

[potetae007]

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

[widtara]

ขอโทษครับเนื่องจาก 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

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

[excel_fever]

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

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

แน่ใจได้อย่างไรครับ ว่าหมายเลขของภาพจะต่อเนื่องกันทุกครั้ง
ลอง
เซลล์ D119 กรอกชื่อภาพ DSC079323.jpg
เซลล์ D120 กรอกชื่อภาพ DSC079324.jpg
ไม่ง่ายกว่าหรือครับ

[widtara]

แน่ใจได้อย่างไรครับ ว่าหมายเลขของภาพจะต่อเนื่องกันทุกครั้ง
ลอง
เซลล์ D119 กรอกชื่อภาพ DSC079323.jpg
เซลล์ D120 กรอกชื่อภาพ DSC079324.jpg
ไม่ง่ายกว่าหรือครับ

มีตัวอย่างให้ดูค่ะ
R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES FRONT LOAD\wk20

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

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

[อรวีร์]

ทดลอง 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

[อรวีร์]

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

[widtara]

โปรแกรมที่เปลี่ยนชื่อแฟ้มใน 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

[อรวีร์]

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