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

[excel_fever]

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]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[13],16),""00"")&""\""&R[74]C[1]&""\""&R[-12]C[13]&""\""&R[-14]C[7]&""\""&R120C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Range("k43").Select
Selection.FormulaR1C1 = "=R[71]C[-7]&""\""&R[72]C[-7]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[5],16),""00"")&""\""&R[74]C[-7]&""\""&R[-12]C[5]&""\""&R[-14]C[7]&""\""&R121C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True

Next i
End Sub

[excel_fever]

รหัสใหม่หลังตัดโฟลเดอร์ 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]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[13],16),""00"")&""\""&R[-12]C[13]&""\""&R[-14]C[7]&""\""&R120C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Range("k43").Select
Selection.FormulaR1C1 = "=R[71]C[-7]&""\""&R[72]C[-7]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[5],16),""00"")&""\""&R[-12]C[5]&""\""&R[-14]C[-1]&""\""&R121C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True

Next i
End Sub

รหัสนี้จะแทรกภาพตามไดเรกทอรี่ที่คุณบอกมา ผมเองก็ไม่สร้างโฟลเดอร์จำลองขนาดนั้นแน่ ที่สำคัญก็อย่างที่บอกไปว่า"คำถาม VBA ผู้ถามควรจะประยุกต์เองได้บ้าง" ดังนั้น ตอนทดสอบผมตัดคำสั่งแทรกภาพออกไป ไฟล์ที่ถูกสร้างขึ้นนั้นจะมีสูตรเพิ่มขึ้นมา สังเกตดูที่พื้นที่ที่ต้องการแทรกภาพ(ในไฟล์ที่ถูกสร้างใหม่) แล้วไล่ดูว่ามีไฟล์/โฟลเดอร์อยู่จริงหรือเปล่า หากผิดแม้แต่อักขระเดียวก็ Error ครับ

[widtara]

รหัสใหม่หลังตัดโฟลเดอร์ 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]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[13],16),""00"")&""\""&R[-12]C[13]&""\""&R[-14]C[7]&""\""&R120C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Range("k43").Select
Selection.FormulaR1C1 = "=R[71]C[-7]&""\""&R[72]C[-7]&""\""&""wk""&TEXT(WEEKNUM(R[-34]C[5],16),""00"")&""\""&R[-12]C[5]&""\""&R[-14]C[-1]&""\""&R121C4"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True

Next i
End Sub

รหัสนี้จะแทรกภาพตามไดเรกทอรี่ที่คุณบอกมา ผมเองก็ไม่สร้างโฟลเดอร์จำลองขนาดนั้นแน่ ที่สำคัญก็อย่างที่บอกไปว่า"คำถาม VBA ผู้ถามควรจะประยุกต์เองได้บ้าง" ดังนั้น ตอนทดสอบผมตัดคำสั่งแทรกภาพออกไป ไฟล์ที่ถูกสร้างขึ้นนั้นจะมีสูตรเพิ่มขึ้นมา สังเกตดูที่พื้นที่ที่ต้องการแทรกภาพ(ในไฟล์ที่ถูกสร้างใหม่) แล้วไล่ดูว่ามีไฟล์/โฟลเดอร์อยู่จริงหรือเปล่า หากผิดแม้แต่อักขระเดียวก็ Error ครับ

ตอนนี้ที่เจอค่ะ
ActiveSheet.Pictures.Insert (Selection.Value) มัน error ตรงนี้ อ้อยก็ค่อยอ่านว่ามันเชื่อมกันยังงัย ให้เวลานิดหนึ่งนะค่ะ ตอนนี้พึ่งหัดทำ ยังมึนๆอยู่ค่ะ

[excel_fever]

ไว้พรุ่งนี้จะสร้าง path จำลองเพื่อทดสอบจริง ๆ ให้ ผมก็อยากรู้เหมือนกัน

[widtara]

ไว้พรุ่งนี้จะสร้าง path จำลองเพื่อทดสอบจริง ๆ ให้ ผมก็อยากรู้เหมือนกัน

แก้ไขไฟล์ให้เรียบร้อยแล้วทดลองใหม่ค่ะ เอาไฟล์นี้ค่ะ ยังไม่ได้ใส่โค้ดอะไรตอนนี้มึนหัวมากเลยด้วยความอยากรู้ ค่ะ
ที่อยู่ของ path ที่ทดลองค่ะ
R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD\wk04\RJ IT\82521\
เข้าจะมีภาพ 1.jpg และ 2.jpg ค่ะ

[excel_fever]

ทดสอบแล้วทำงานได้ครับ แต่ทดสอบแค่ชีตเดียว เวลานำไปใช้ เซลล์ D114 เปลี่ยน E ในไฟล์แนบ เป็น Drive จริงของเครื่องคุณ

รหัสเดิมก็ใช้ได้ แต่ปรับใหม่นิดหน่อย

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"
ActiveSheet.Pictures.Insert (Selection.Value)
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"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

[widtara]

ทดสอบแล้วทำงานได้ครับ แต่ทดสอบแค่ชีตเดียว เวลานำไปใช้ เซลล์ D114 เปลี่ยน E ในไฟล์แนบ เป็น Drive จริงของเครื่องคุณ

รหัสเดิมก็ใช้ได้ แต่ปรับใหม่นิดหน่อย

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"
ActiveSheet.Pictures.Insert (Selection.Value)
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"
ActiveSheet.Pictures.Insert (Selection.Value)
Application.DisplayAlerts = False
ActiveWorkbook.Close True
Next i
End Sub

ดึงได้แล้วค่ะแต่ภาพไม่อยู่ในพื้นที่ที่กำหนด
แต่จะไปอยู่ในช่วง D3 ถึง D20 และ ภาพ 2 ภาพ ก็ซ้อนทับกันอยู่ค่ะ
ขนาดภาพ 16.92 x 22.57 และต้องการกำหนดให้ภาพมีขนาด 13 x 17.34 จะกำหนดได้ไหมค่ะ

[orange_soi9]

ดึงได้แล้วค่ะแต่ภาพไม่อยู่ในพื้นที่ที่กำหนด
แต่จะไปอยู่ในช่วง D3 ถึง D20 และ ภาพ 2 ภาพ ก็ซ้อนทับกันอยู่ค่ะ
ขนาดภาพ 16.92 x 22.57 และต้องการกำหนดให้ภาพมีขนาด 13 x 17.34 จะกำหนดได้ไหมค่ะ

ลองศึกษาและพยายามเขียน Code ด้วยตัวเองขึ้นมาก่อนดีไหมคะ? ถ้าลองพยายามทำแล้ว แต่ติดขัดปัญหาตรงไหนค่อยมาถามอีกทีนะคะ อาจารย์และทุกคนในที่นี้พร้อมช่วยอยู่แล้วค่ะ :smile:
ลองดู Code จาก Link นี้เป็นตัวอย่างก่อนก็ได้นะคะ
http://excel.bigresource.com/auto-in...-VrrpomxW.html

[excel_fever]

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"
ActiveSheet.Pictures.Insert (Selection.Value)
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"
ActiveSheet.Pictures.Insert (Selection.Value)

ภาพที่ 1 ถูกแทรกที่ C43
ภาพที่ 2 ถูกแทรกที่ L43
รหัสถูกต้องครับ ผมเองก็ทดสอบแล้ว
และเรื่องขนาดภาพ ผมเคยเตือนตั้งแต่ตอนต้นแล้ว

2. ภาพที่จะแทรก ควรจะผ่านการตกแต่งเรียบร้อยแล้ว (คือแทรกมาแล้วไม่ต้องมาย่อ/ขยาย
หรือทำอะไรอีก) ทุกภาพ

เรื่องทำได้หรือไม่ได้ จึงยังไม่ขอตอบครับ

[widtara]

ภาพที่ 1 ถูกแทรกที่ C43
ภาพที่ 2 ถูกแทรกที่ L43
รหัสถูกต้องครับ ผมเองก็ทดสอบแล้ว
และเรื่องขนาดภาพ ผมเคยเตือนตั้งแต่ตอนต้นแล้ว

เรื่องทำได้หรือไม่ได้ จึงยังไม่ขอตอบครับ

ทดลองทำที่เครื่องอีกครั้ง ภาพก็ยังไม่อยู่ในตำแหน่งให้ค่ะ อ้อยแนบภาพมาให้ดู ค่ะ
ไปเจอ code นี้ในเว็บที่คุณส้มให้มาก เกี่ยวกับการจัดการภาพ แต่ก็ประยุกต์ไม่เป็นค่ะ เลยเอามาให้ดูค่ะ

Sub test()
On Error Resume Next
Set pic = ActiveSheet.Pictures.Insert("C:
ange.gif")
On Error Goto 0
If Not pic Is Nothing Then 'Found it!'
Set rng = ActiveCell
With pic
.Height = rng.Height
.Width = rng.Width
.Left = rng.Left
.Top = rng.Top
End With
End If
End Sub

ส่วนบรรทัดนี้หมายความว่าอย่างไรค่ะ แปล code ไม่ออกค่ะ
= "=R[71]C[1]&""\""&R[72]C[1]&""\""&R[73]C[1]&""\""&R[74]C[1]&""\""&R[75]C[1]&""\""&R119C4"

Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"