PDA

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



widtara
15 Jun 2011, 10:44
ให้VBAหาภาพในfoldersและใส่ภาพในไฟล์excelอัตโนมัติ
ต่อจากให้ VBA แยกชีทค่ะ
ปัจจุบันใช้ code
Sub Macro1()
Dim i As Integer
For i = 1 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Worksheets(i).Copy
'ActiveSheet.Name = Workbooks("sheet.xlsm").Sheets(i).Range("O4").Value
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("O4").Value & Range("j13").Value & ".xls", FileFormat:=xlExcel8, CreateBackup:=False
ActiveWorkbook.Close True
Next i
End Sub

เพื่อแยกชีท แต่ในไฟล์ excel อยากให้ใส่ภาพให้กับ cel ไปพร้อมกับการแยกชีทได้ไหมค่ะโดยมีเส้นทางดังนี้
1. ไดร์ที่จัดเก็บภาพ R:\SQA DEDUCT PAYMENT Y11
มี 3 folders หลักคือ
1.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER
2.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES FRONT LOAD
3.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD
2.ภาพใน 3 folders ก็จะประกอบด้วย folders ย่อยชื่อ wk01 ถึง wk52 (เป็นสัปดาห์ใน 1 ปีค่ะ)
3.ใน folders ย่อยชื่อ wk01 ถึง wk52 ประกอบด้วย Folders ชื่อ RJI และ RJL
4.ใน folders ชื่อ RJI และ RJL ประกอบไปด้วย Folders ที่มีเลข 5 ถึง 6 หลัก (เป็นหมายเลขเอกสารค่ะ)
5.หมายเลขเอกสารที่เป็นชื่อ Folders จะไม่ซ้ำกันของ Folders ที่มีทั้งหมด ใน3 folders หลักคือ
1.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER
2.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES FRONT LOAD
3.R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD
6.ภายใต้ Folders ที่มีเลข 5 ถึง 6 หลัก (เป็นหมายเลขเอกสารค่ะ) นั้นจะมี 3 ภาพ และมี 2 ภาพกำหนดให้ชื่อ 1 และ 2

สิ่งที่ต้องการคือ
1.ต้องการดึงภาพ 1 ไปใส่ cel ชื่อ pic1
2.ต้องการดึงภาพ 2 ไปใส่ cel ชื่อ pic2
3.โดยมีเงื่อนไขว่า ต้องเช็ครหัสเอกสารก่อนใน cel J29 ของทุก sheet ทั้งหมดภายใน worksbook

ไฟล์แนบ
1.มีภาพ Foldersประกอบ เหลือ 2 ภาพ แนบไม่ได้ค่ะ
2.มีไฟล์ .xlsm ประกอบ ชื่อ AddPic เหลือ 1 ไฟล์ตัวอย่าง แนบไม่ได้ค่ะ

ถามว่าจะต้องเพิ่ม code ต่อจาก code ที่มีอย่างไรบ้างค่ะ

excel_fever
15 Jun 2011, 11:30
คิดว่าน่าจะเพิ่มเติมดังนี้ครับ
1. ชีตที่ให้แทรกนั้นต้องมีเซลล์ที่กรอกชื่อและที่เก็บไฟล์ภาพ
2. ภาพที่จะแทรก ควรจะผ่านการตกแต่งเรียบร้อยแล้ว (คือแทรกมาแล้วไม่ต้องมาย่อ/ขยาย หรือทำอะไรอีก) ทุกภาพ
3. สำหรับคนอื่นผมไม่รู้ แต่สำหรับผมนั้นการเก็บภาพเป็นโฟลเดอร์ย่อย ๆ ๆ ๆ ๆ หลายชั้นจะทำให้เขียนรหัสยาก
4. เวลาทำเอกสารทำไมไม่แทรกภาพไปเลยล่ะครับ แค่ภาพเดียวเอง:confused::confused:

VBA ใส่ภาพน่ะไม่ยากหรอกครับ ผมว่ายากที่การหา

widtara
15 Jun 2011, 12:19
คิดว่าน่าจะเพิ่มเติมดังนี้ครับ
1. ชีตที่ให้แทรกนั้นต้องมีเซลล์ที่กรอกชื่อและที่เก็บไฟล์ภาพ
2. ภาพที่จะแทรก ควรจะผ่านการตกแต่งเรียบร้อยแล้ว (คือแทรกมาแล้วไม่ต้องมาย่อ/ขยาย หรือทำอะไรอีก) ทุกภาพ
3. สำหรับคนอื่นผมไม่รู้ แต่สำหรับผมนั้นการเก็บภาพเป็นโฟลเดอร์ย่อย ๆ ๆ ๆ ๆ หลายชั้นจะทำให้เขียนรหัสยาก
4. เวลาทำเอกสารทำไมไม่แทรกภาพไปเลยล่ะครับ แค่ภาพเดียวเอง:confused::confused:

VBA ใส่ภาพน่ะไม่ยากหรอกครับ ผมว่ายากที่การหา

เหตุผลคือ
1.ไฟล์ที่แยกมีชื่อ เอกสาร MA เป็นเลขที่ไม่ซ้ำ
2.ไฟล์ที่แยกมาต่อ 1 อาทิตย์ มีมากกว่า 200 ไฟล์ แต่ละไฟล์จะต้องมานั่งเพิ่มภาพเข้าไป
ประมาณ 2 ภาพต่อไฟล์
3.ภาพที่ใส่ถ้า บีบภาพให้เล็กมากจะมีผลทำให้มองภาพไม่ชัด เพราะเป็นการบอกปัญหาคุณภาพ ต่อผู้ไม่เข้าใจ คือ supplier ค่ะ
4.การวาง folder เป็นการวางภาพโดยทีมหนึ่ง ลักษณะการวางเป็นการวางแบบซ้ำๆปัจจุบันไม่ได้เปลี่ยนชื่อไฟล์เอาตามที่รันจากกล้องเลย แต่มีเลข ma ที่สามารถระบุได้หากทำการดึงภาพเพราะไม่ซ้ำค่ะ

ช่วยหาหนทางหน่อยนะค่ะ เพราะหากทำได้จะลดเวลาการทำงานลงไปมากเลยค่ะ:yesnod:

orange_soi9
15 Jun 2011, 12:46
ส้มคิดไว้แล้วเชียวว่างานของเจ้าของกระทู้ ยังไม่จบแค่กระทู้นั้นแน่ๆ :smile:

widtara
15 Jun 2011, 12:49
ส้มคิดไว้แล้วเชียวว่างานของเจ้าของกระทู้ ยังไม่จบแค่กระทู้นั้นแน่ๆ :smile:

เอาทีละท่อนดีกว่า ถ้ารวมครั้งเดียว กลัวสมอง(ตัวเอง) จะรับไม่ทัน ค่ะ :yesnod:

excel_fever
15 Jun 2011, 13:04
คำถามเรื่อง VBA ผู้ใช้ต้องสามารถประยุกต์รหัสเองได้บ้าง

ผมขอแนะนำดังนี้ครับ
ก่อนคำสั่ง Thisworkbook.Close True ให้ใส่ขั้นตอนต่อไปนี้ลงไป
สั่งให้ VBA เขียนสูตร ค้นหาที่เก็บภาพและชื่อภาพแล้วเอามาเชื่อมต่อกัน
โฟลเดอร์1&\&โฟลเดอร์2&\&โฟลเดอร์3&\&โฟลเดอร์....&\&ชื่อภาพ.นามสกุล
โดย
โฟลเดอร์1=ค่าจากเซลล์ใหน
โฟลเดอร์2=ค่าจากเซลล์ใหน
โฟลเดอร์3=ค่าจากเซลล์ใหน
.
.
.
ชื่อภาพ=ค่าจากเซลล์ใหน.นามสกุลอะไร

แล้วจึงจะสามารถแทรกได้ครับ

widtara
15 Jun 2011, 14:08
ผมขอแนะนำดังนี้ครับ
ก่อนคำสั่ง Thisworkbook.Close True ให้ใส่ขั้นตอนต่อไปนี้ลงไป
สั่งให้ VBA เขียนสูตร ค้นหาที่เก็บภาพและชื่อภาพแล้วเอามาเชื่อมต่อกัน
โฟลเดอร์1&\&โฟลเดอร์2&\&โฟลเดอร์3&\&โฟลเดอร์....&\&ชื่อภาพ.นามสกุล
โดย
โฟลเดอร์1=ค่าจากเซลล์ใหน
โฟลเดอร์2=ค่าจากเซลล์ใหน
โฟลเดอร์3=ค่าจากเซลล์ใหน
.
.
.
ชื่อภาพ=ค่าจากเซลล์ใหน.นามสกุลอะไร

แล้วจึงจะสามารถแทรกได้ครับ

ช่วยตรวจสอบไฟล์ดูให้หน่อยค่ะ
ดึงภาพ
1 EVENT PICTURES TOP LOAD=D115
2 wk04=D116
3 sub=D117
4 RJ IT=D118
5 82521=D119
6 1.JPG=D120
7 2.JPG=D121

orange_soi9
15 Jun 2011, 14:44
ทำไมมี Folder sub เพิ่มเข้ามาอีกคะ? :confused::confused:

excel_fever
15 Jun 2011, 15:00
ลองเอาไปทดสอบดูครับ

widtara
15 Jun 2011, 15:20
ลองเอาไปทดสอบดูครับ

ต้องขอโทษด้วยค่ะ คือไม่มี Folder sub ค่ะตาลายไปหน่อย
และลองรันสูตรแล้วค่ะ ติด Error ค่ะ
แนบไฟล์มาให้ใหม่ค่ะ

excel_fever
15 Jun 2011, 15:21
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
15 Jun 2011, 15:42
รหัสใหม่หลังตัดโฟลเดอร์ 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
15 Jun 2011, 16:13
รหัสใหม่หลังตัดโฟลเดอร์ 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
15 Jun 2011, 16:41
ไว้พรุ่งนี้จะสร้าง path จำลองเพื่อทดสอบจริง ๆ ให้ ผมก็อยากรู้เหมือนกัน

widtara
15 Jun 2011, 16:45
ไว้พรุ่งนี้จะสร้าง path จำลองเพื่อทดสอบจริง ๆ ให้ ผมก็อยากรู้เหมือนกัน
แก้ไขไฟล์ให้เรียบร้อยแล้วทดลองใหม่ค่ะ เอาไฟล์นี้ค่ะ ยังไม่ได้ใส่โค้ดอะไรตอนนี้มึนหัวมากเลยด้วยความอยากรู้ ค่ะ
ที่อยู่ของ path ที่ทดลองค่ะ
R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD\wk04\RJ IT\82521\
เข้าจะมีภาพ 1.jpg และ 2.jpg ค่ะ

excel_fever
16 Jun 2011, 10:23
ทดสอบแล้วทำงานได้ครับ แต่ทดสอบแค่ชีตเดียว เวลานำไปใช้ เซลล์ 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
16 Jun 2011, 13:29
ทดสอบแล้วทำงานได้ครับ แต่ทดสอบแค่ชีตเดียว เวลานำไปใช้ เซลล์ 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
16 Jun 2011, 13:37
ดึงได้แล้วค่ะแต่ภาพไม่อยู่ในพื้นที่ที่กำหนด
แต่จะไปอยู่ในช่วง D3 ถึง D20 และ ภาพ 2 ภาพ ก็ซ้อนทับกันอยู่ค่ะ
ขนาดภาพ 16.92 x 22.57 และต้องการกำหนดให้ภาพมีขนาด 13 x 17.34 จะกำหนดได้ไหมค่ะ
ลองศึกษาและพยายามเขียน Code ด้วยตัวเองขึ้นมาก่อนดีไหมคะ? ถ้าลองพยายามทำแล้ว แต่ติดขัดปัญหาตรงไหนค่อยมาถามอีกทีนะคะ อาจารย์และทุกคนในที่นี้พร้อมช่วยอยู่แล้วค่ะ :smile:
ลองดู Code จาก Link นี้เป็นตัวอย่างก่อนก็ได้นะคะ
http://excel.bigresource.com/auto-insert-and-resize-Picture-VrrpomxW.html

excel_fever
16 Jun 2011, 13:49
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
16 Jun 2011, 14:10
ภาพที่ 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"

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

เจอ code เกี่ยวกับการดึงภาพ แต่มาประยุกต์ไม่เป็นค่ะ คือ code ที่พี่เขาช่วยดูให้ทดลองทำแล้วก็บอกว่า ภาพมาอยู่ในตำแหน่งที่กำหนด แต่อ้อยทดลองทำที่เครื่องหลายต่อหลายครั้งก็ยังไม่สำเร็จค่ะ
เห็น code นี้อยู่เห็นมีการกำหนด ActiveSheet.Range("c3:d9")
คิดว่าของเราน่าจะกำหนดดูบาง แต่พอไปทำไม่ได้ผลเลย มึนกำลังสองเลยค่ะ

Option Explicit

'With the macro below you can insert pictures and fit them to any range in a worksheet.

Option Explicit
Sub InsertPicInRange()
With Application
.ScreenUpdating = False
Dim picToOpen As String
picToOpen = .GetOpenFilename("Pics (*.bmp), *.bmp")
If picToOpen <> "" Then
InsertPictureInRange picToOpen, ActiveSheet.Range("c3:d9")
End If
.ScreenUpdating = True
End With
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub

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

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

Code แนะนำมาค่ะ
Sub ShowPicture1()
Dim r As Range, ra As Range
Dim imgIcon As Object
Dim obj As Object
On Error Resume Next
With Worksheets("Sheet1")
Set ra = .Range("G4", .Range("F65536").End(xlUp).Offset(0, 1))
End With
For Each obj In ActiveSheet.Shapes
If Left(obj.Name, 4) = "Pict" Then
obj.Delete
End If
Next obj
For Each r In ra
Set imgIcon = ActiveSheet.Shapes.AddPicture( _
Filename:="D:\" & r.Offset(0, -1).Value & ".jpg", LinkToFile:=False, _
SaveWithDocument:=True, Left:=r.Left, Top:=r.Top, _
Width:=r.Width, Height:=r.Height)
Next r
End Sub
โดยมีตัวอย่างจาก http://******.blogspot.com/2011/05/folder-excel.html
แต่จากตัวอย่างเขามีปุ่มด้วย อ้อยทำไม่เป็นเหมือนเขาค่ะ

excel_fever
16 Jun 2011, 15:30
พื้นที่ที่จะแทรกภาพ เป็นแนวตั้ง แต่ภาพเป็นแนวนอน ย่อหรือขยายแล้วก็ผิดรูปร่าง แถมภาพนั้น Dimension อาจใหญ่มาก ๆ ถึงจะย่อลงแล้วก็ยังไม่ได้ Compress ทำให้ไฟล์มีขนาดใหญ่ตามไปด้วย ผมถึงได้บอกให้แต่งภาพก่อนไงครับ

ส่วนที่บอกว่าแปล Code ไม่ออกนั้นให้ลองเปิดไฟล์ที่ได้จากการแยกชีต (ที่ผมแนบไปให้) ดูที่เซลล์ C43 กับ L43 จะเป็นสูตรอยู่ นั่นแหละครับคือสูตรที่ได้จากบรรทัด Selection.FormulaR1C1=......

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

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

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"

with ActiveSheet.Pictures.Insert (Selection.Value)
.Top = Range("c43:j94").Top
.Left = Range("c43:j94").Left
.Height = Range("c43:j94").Height
.Width = Range("c43:j94").Width
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("k43:v94").Top
.Left = Range("k43:v94").Left
.Height = Range("k43:v94").Height
.Width = Range("k43:v94").Width
end with

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

excel_fever
17 Jun 2011, 14:42
ตรงคำสั่งจัดภาพที่สองน่าจะเป็น L43 นะครับ เพราะเขียนสูตรที่ L43

pooky
17 Jun 2011, 15:03
ตรงคำสั่งจัดภาพที่สองน่าจะเป็น L43 นะครับ เพราะเขียนสูตรที่ L43
ผิดตำแหน่งจริงๆด้วย แก้ไขแล้วค่ะโดยการลบออก เพราะมี selectionอยู่แล้ว

pooky
17 Jun 2011, 15:53
ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง



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"

with ActiveSheet.Pictures.Insert (Selection.Value)
.Top = Range("c43:j94").Top
.Left = Range("c43:j94").Left
If .Height > .Width Then
.Height = Range("c43:j94").Height
Else
.Width = Range("c43:j94").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("k43:v94").Top
.Left = Range("k43:v94").Left
If .Height > .Width Then
.Height = Range("k43:v94").Height
Else
.Width = Range("k43:v94").Width
End If
end with

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

widtara
28 Jun 2011, 15:02
ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง



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"

with ActiveSheet.Pictures.Insert (Selection.Value)
.Top = Range("c43:j94").Top
.Left = Range("c43:j94").Left
If .Height > .Width Then
.Height = Range("c43:j94").Height
Else
.Width = Range("c43:j94").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("k43:v94").Top
.Left = Range("k43:v94").Left
If .Height > .Width Then
.Height = Range("k43:v94").Height
Else
.Width = Range("k43:v94").Width
End If
end with

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


คำสั่งใช้งานได้ดีค่ะ แต่ยังติดนิดหนึ่งค่ะ ภาพที่วิ่งมา 2 ภาพ ไปปิดหัวเรื่องไว้
ขนาดภาพไม่เท่ากัน
ขนาดไฟล์ประมาณ 340-355 อ้อยต้องมาทำการ cut ภาพ แล้ววางแบบ JPG ขนาดไฟล์จะเหลือประมาณ 150-200
ที่ C43 และ L43 พอรันออกมาแล้ว แสดงตัวหนังสือเป็นสีดำ แต่กำหนดไว้ตอนแรกให้เป็น สีขาว เพื่อไม่แสดงให้เห็น ต้องการให้เป็นตัวหนังสือสีขาวเลยจะเขียนคำสั่งแบบไหนค่ะ
มีภาพผลลัพธ์มาให้ดูค่ะ

widtara
28 Jun 2011, 15:31
คำสั่งใช้งานได้ดีค่ะ แต่ยังติดนิดหนึ่งค่ะ ภาพที่วิ่งมา 2 ภาพ ไปปิดหัวเรื่องไว้
ขนาดภาพไม่เท่ากัน
ขนาดไฟล์ประมาณ 340-355 อ้อยต้องมาทำการ cut ภาพ แล้ววางแบบ JPG ขนาดไฟล์จะเหลือประมาณ 150-200
ที่ C43 และ L43 พอรันออกมาแล้ว แสดงตัวหนังสือเป็นสีดำ แต่กำหนดไว้ตอนแรกให้เป็น สีขาว เพื่อไม่แสดงให้เห็น ต้องการให้เป็นตัวหนังสือสีขาวเลยจะเขียนคำสั่งแบบไหนค่ะ
มีภาพผลลัพธ์มาให้ดูค่ะ

อ้อยเปลี่ยนตำแหน่งค่ะ
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("f52:j86").Top
.Left = Range("f52:j86").Left
If .Height > .Width Then
.Height = Range("f52:j86").Height
Else
.Width = Range("f52:j86").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("m52:s86").Top
.Left = Range("m52:s86").Left
If .Height > .Width Then
.Height = Range("m52:s86").Height
Else
.Width = Range("m52:s86").Width
End If
End With

ได้ผลลัพธ์ดังภาพค่ะ:yesnod: แต่งงคือขนาดภาพ ที่1 มันจะใหญ่กว่าภาพที่ 2 ทั้งที่ถ่ายมาก็ตั้งกล้องรีไซด์แล้ว เป็นแบบส่งเมล์ ไม่ทราบสาเหตุ ค่ะ ขนาดไฟล์ที่ได้ 336 KB ขนาดภาพตาม ภาพที่ 1 กำลังดีค่ะ ไม่ต้องมาย่อภาพอีกเลย คือ 15.11 cm x 20.53 cm

หลังจากทำการคลิกขวา ตัดภาพ 2 ภาพ และวางแบบ jpg ใหม่ ได้ขนาดไฟล์เพียง 148 KB

อยากทราบว่า VBA ที่กำหนด เราก็เรียกภาพ เป็น JPG แล้ว ทำไม มันใหญ่ถึง 336 KB เราต้องมาตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

เราสามารถกำหนดไฟล์ให้เล็กเป็นกว่านี้ได้ไหมค่ะ เป็นการส่งเมล์ทุกไฟล์ที่ทำค่ะ

ส่วนเรื่องตัวหนังสือก็จัดการเรียบร้อยแล้วค่ะ ยังสงสัยแค่เรื่องขนาดภาพ กับขนาดไฟล์ค่ะ:nonod:


ขอแทรกอีกเรื่องหนึ่งนะค่ะ มีใครช่วยกำหนดให้ภาพที่ 2 ไม่ให้แสดงได้ไหมค่ะ ที่บริษัทใช้ 2007 ไม่อยากให้ขึ้นมาค่ะ :confused:

widtara
28 Jun 2011, 17:48
อ้อยเปลี่ยนตำแหน่งค่ะ
With ActiveSheet.Pictures.Insert(Selection.Value)
.Top = Range("f52:j86").Top
.Left = Range("f52:j86").Left
If .Height > .Width Then
.Height = Range("f52:j86").Height
Else
.Width = Range("f52:j86").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("m52:s86").Top
.Left = Range("m52:s86").Left
If .Height > .Width Then
.Height = Range("m52:s86").Height
Else
.Width = Range("m52:s86").Width
End If
End With

ได้ผลลัพธ์ดังภาพค่ะ:yesnod: แต่งงคือขนาดภาพ ที่1 มันจะใหญ่กว่าภาพที่ 2 ทั้งที่ถ่ายมาก็ตั้งกล้องรีไซด์แล้ว เป็นแบบส่งเมล์ ไม่ทราบสาเหตุ ค่ะ ขนาดไฟล์ที่ได้ 336 KB ขนาดภาพตาม ภาพที่ 1 กำลังดีค่ะ ไม่ต้องมาย่อภาพอีกเลย คือ 15.11 cm x 20.53 cm

หลังจากทำการคลิกขวา ตัดภาพ 2 ภาพ และวางแบบ jpg ใหม่ ได้ขนาดไฟล์เพียง 148 KB

อยากทราบว่า VBA ที่กำหนด เราก็เรียกภาพ เป็น JPG แล้ว ทำไม มันใหญ่ถึง 336 KB เราต้องมาตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

เราสามารถกำหนดไฟล์ให้เล็กเป็นกว่านี้ได้ไหมค่ะ เป็นการส่งเมล์ทุกไฟล์ที่ทำค่ะ

ส่วนเรื่องตัวหนังสือก็จัดการเรียบร้อยแล้วค่ะ ยังสงสัยแค่เรื่องขนาดภาพ กับขนาดไฟล์ค่ะ:nonod:


ขอแทรกอีกเรื่องหนึ่งนะค่ะ มีใครช่วยกำหนดให้ภาพที่ 2 ไม่ให้แสดงได้ไหมค่ะ ที่บริษัทใช้ 2007 ไม่อยากให้ขึ้นมาค่ะ :confused:


มีคำสั่งที่กำหนดให้ภาพที่ 2 มีขนาดเท่ากับภาพที่1 ไหมค่ะ ต้องการให้รันไฟล์แล้ว ภาพ 2 ภาพมีขนาดเท่ากันค่ะ

pooky
28 Jun 2011, 17:56
1.ความกว้างของ cell Range("f52:j86") กับ Range("m52:s86") ไม่เท่ากัน
ลองทดสอบโดยการขยายความกว้างของ cell m52 ก็ได้ แล้วดู ความสูงของภาพจะเปลี่ยนไป
แล้วจะเห็นความสัมพันธ์ ค่ะ
2.เรื่องขนาดไฟล์ ไม่เข้าใจตรง ตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

จริงๆถ้าเป็นภาพเดิมไม่ได้ตกแต่งเพิ่ม ก็ไม่น่าจะเกี่ยวกัน อันนี้ไม่ทราบ

widtara
28 Jun 2011, 22:20
1.ความกว้างของ cell Range("f52:j86") กับ Range("m52:s86") ไม่เท่ากัน
ลองทดสอบโดยการขยายความกว้างของ cell m52 ก็ได้ แล้วดู ความสูงของภาพจะเปลี่ยนไป
แล้วจะเห็นความสัมพันธ์ ค่ะ
2.เรื่องขนาดไฟล์ ไม่เข้าใจตรง ตัดภาพวาง เป็น JPG ถึงจะได้ไฟล์ที่เล็กลง

จริงๆถ้าเป็นภาพเดิมไม่ได้ตกแต่งเพิ่ม ก็ไม่น่าจะเกี่ยวกัน อันนี้ไม่ทราบ


งานที่ได้มาทดสอบแล้วค่ะ ว่าขนาดไฟล์ต่างกันมาก ไฟล์ที่ได้มีจำนวนมากต่ออาทิตย์ เพราะต้องแยกส่งให้ supplier และส่งเมล์ จำเป็นต้องหาวิธีการทำให้เล็กมากที่สุด ก็คือตัดภาพแล้ววางเป็น jpg ที่ excel จะทำให้ภาพเล็กลงค่ะ:yesnod:

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

pooky
28 Jun 2011, 22:30
งานที่ได้มาทดสอบแล้วค่ะ ว่าขนาดไฟล์ต่างกันมาก ไฟล์ที่ได้มีจำนวนมากต่ออาทิตย์ เพราะต้องแยกส่งให้ supplier และส่งเมล์ จำเป็นต้องหาวิธีการทำให้เล็กมากที่สุด ก็คือตัดภาพแล้ววางเป็น jpg ที่ excel จะทำให้ภาพเล็กลงค่ะ:yesnod:

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

ใช้อะไรตัดหรือค่ะ และยังต้องการ ใช้vba ให้แทรกภาพอีกหรือเปล่า

widtara
28 Jun 2011, 23:02
ใช้อะไรตัดหรือค่ะ และยังต้องการ ใช้vba ให้แทรกภาพอีกหรือเปล่า

งานอ้อยมีขั้นตอนดังนี้ค่ะ
:type:
1.มี data อยู่หนึ่งไฟล์จัดเรียงข้อมูล 1 บรรทัดต่อข้อมูลออกมาเป็น 1 report
2.ข้อมูลเพิ่มลงมาด้านล่างเรื่อยๆ
3.จัดทำฟอร์ม report 1 ไฟล์ โดยมี sheet ส่งค่า 1 sheet ค่ะ และมี เป็น 100 sheet รับค่าแสดงเป็น 1 รายงาน เพราะแต่ละ sheet เป็นข้อมูลที่ต่างกัน แต่อยู่ใน from เดียวกัน เหมือนตัวอย่างที่ให้ดึงภาพนะค่ะ
4.เมื่อได้ report แล้วก็ทำการแยก sheet ออกมา 1 sheet ต่อ 1ไฟล์ เพราะเราแยกส่งให้ supplier ต่างเจ้ากันค่ะ

5.แต่ละไฟล์ก็มีภาพอธิบายปัญหา ก่อนหน้านี้ อ้อยต้องคลิกขวา new book ค่ะ หันมาใช้สูตร แยกชีท และให้บันทึกและปิดไฟล์อัตโนมัติ โดยมีทีมงานคุณภาพนี้ละค่ะช่วยเหลือ
:type:
6.จะมีทีมงานอ้อยที่บริษัทเขาต้องมาใส่ภาพลักษณะแบบที่เจอนะค่ะ ตกอาทิตย์หนึ่งก็เยอะมาก โดย การแทรกภาพค่ะ เมื่อได้ภาพแล้ว ลอง save ดูนะค่ะ ขนาดไฟล์จะใหญ่พอดู แต่เมื่อคลิกขวาที่ภาพ และวางใหม่เป็น jpg และ save ค่ะ ขนาดจะลดลงมา
อันนี้ ผู้จัดการแนะนำให้ทำ ค่ะ + จำเป็น เพราะต้องแนบไฟล์ส่งเมล์เยอะมาก

:type:
7.เลยคิดว่าถ้าแยก sheet อยู่แล้วก็ให้ไปดึงภาพพร้อมกันเลย จะลดเวลาทำงานลงมาก
+ตอนนี้ที่บริษัทไม่มีใครรู้เรื่อง VBA เลย อ้อยกำลัง ทดลองทำให้ใครๆเห็น ประโยชน์ของ VBA ด้วยค่ะ

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

ที่ไปเรียนเป็น 2003 แต่ที่บริษัท เป็น 2007 ทั้งหมด เขาเปลี่ยนทั่วโลกเฉพาะบริษัทอ้อยค่ะ อย่างที่รู้ 2007 ยังมีข้อบกพร่องที่เยอะ จนบางครั้งหลายคนบอกว่าก็ยกเลิกใช้ไป ทำไม่ได้เหรอค่ะ เพราะบริษัทเปลี่ยน นี้ยังดีนะค่ะ ที่ไม่บล๊อคเว็บนี้ ที่บริษัทยังเข้าได้อยู่ ไม่อย่างนั้น แย่เลย:rolleyes5:


:hand: เพิ่มเติมค่ะ อย่างไรก็ต้องใช้ VBA + กับการมานั่งจัดภาพอีกครั้งค่ะ เพราะภาพต้องมีการชี้ลูกศรถึงปัญหา วงกลมสีแดงบ้างอธิบายเพิ่มเติมด้วยซึ่งนอกเหนือจากสูตรแล้ว เพราะเป็นงานคุณภาพเราต้องอธิบายงานที่ค่ะ ซึ่งเป็นการออก report อธิบายการเสียหายของ part ต้องบอกจุดเสียหายเพิ่มเติมเพื่อชี้แจงปัญหา งานถึงจะสมบูรณ์ค่ะ ส่งภาพเปล่าอย่างเดียวไม่ได้ เพราะเป็นการหักเงินค่ะ

neang
29 Jun 2011, 10:23
ผมแนะนำเกี่ยวกับเรื่องภาพ ว่าให้เราวาด image tool ก่อนแล้วก็สั่ง image โหลดภาพอีกที ขนาดภาพจะขึ้นอยู่กับ ขนาด tool ไม่ได้ขึ้นกับขนาดของfileภาพครับ ไม่รู้ว่าจะตรงกับความต้องการหรือเปล่านะครับ ปล ไม่ได้อ่านตั้งแต่ comment แรกนะครับ แต่คิดว่าน่าจะเป็นลักษณะดึงภาพมาแล้ววางตรงๆเลย

vajra
29 Jun 2011, 11:01
น่าจะลองวิธีแทรกภาพลงใน Chart

widtara
29 Jun 2011, 11:26
ผมแนะนำเกี่ยวกับเรื่องภาพ ว่าให้เราวาด image tool ก่อนแล้วก็สั่ง image โหลดภาพอีกที ขนาดภาพจะขึ้นอยู่กับ ขนาด tool ไม่ได้ขึ้นกับขนาดของfileภาพครับ ไม่รู้ว่าจะตรงกับความต้องการหรือเปล่านะครับ ปล ไม่ได้อ่านตั้งแต่ comment แรกนะครับ แต่คิดว่าน่าจะเป็นลักษณะดึงภาพมาแล้ววางตรงๆเลย

สรุปได้ไอเดียเรื่องการทำให้ภาพมีขนาดเท่ากัน

ตอนนี้แต่ละไฟล์มี ความต้องการดึงภาพ 1 และ 2 มา สังเกตุว่า ภาพที่ 1 กับ 2 ไม่เท่ากัน ทั้งที่ภาพจริงเท่ากันค่ะ

วิธีแก้ไขค่ะ

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


หลังจากนั้นที่ไฟล์

.Top = Range("m55:s86").Top
.Left = Range("m55:s86").Left

.Height = Range("f55:j80").Height
.Width = Range("f55:j80").Width

รองรับภาพที่ 1

.Top = Range("m55:s86").Top
.Left = Range("m55:s86").Left
.Height = Range("m55:s86").Height
.Width = Range("m55:s86").Width

รองรับภาพที่ 2

ที่ไฟล์ excel แค่อ้อยปรับ ความกว้าง*ยาว ของ เซลล์ ในช่วง 2 ช่วงให้เท่ากัน ภาพก็เท่ากันแล้วค่ะ

ไม่ต้องสร้างอะไรเพิ่มเติมเลยค่ะ

ขอบคุณทีมงานทุกคนที่คอยให้กำลังใจและช่วยเหลือมาโดยตลอดค่ะ จะนำงานนี้ไปพัฒนาให้ดีกว่านี้แล้วจะกลับมารายงานค่ะ

pooky
29 Jun 2011, 12:29
ขอปรับปรุงcodeใหม่ เนื่องจากทดลองแล้ว code จะให้ปรับขนาดภาพตาม Height หรือ Width
อย่างไดอย่างหนึ่งแล้วอีกด้านจะขยายตามเอง ปัญหาคือถ้าตั้งให้ขยายตาม Width ภาพที่มีขนาดHeight>Widthจะล้นลงมาด้านล่าง



ความกว้างของ cell Range("f52:j86") กับ Range("m52:s86") ไม่เท่ากัน
ลองทดสอบโดยการขยายความกว้างของ cell m52 ก็ได้ แล้วดู ความสูงของภาพจะเปลี่ยนไป
แล้วจะเห็นความสัมพันธ์ ค่ะ


2 post ที่แล้ว คือคำตอบ ว่าทำไมไม่เท่ากัน

widtara
29 Jun 2011, 15:57
เรื่องราวปัญหายุ่งๆของการเรื่อง ภาพก็ยังไม่จบมาดูปัญหาภาคต่อนะค่ะ

R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD\wk26\RJ LT\105980

DSC00097.JPG
DSC00098.JPG
DSC00099.JPG
Thumbs.db

ภาพรวมของภาพใน Folders ค่ะ 105980 เป็นชื่อ ma ก่อนที่สูตรจะทำงาน อ้อยต้องทำการเปลี่ยนชื่อไฟล์ภาพ 2 ภาพ
DSC00098.JPG เปลี่ยนเป็น 1.JPG
DSC00099.JPG เปลี่ยนเป็น 2.JPG

ส่วนภาพแรกไม่ต้องการ และจะมีไฟล์ Thumbs.db ติดมาทุก Foldersค่ะ

ปัญหาคือ มี Folders แบบนี้ประมาณ 200 Folders ขึ้นไป และมี ภาพข้างใน 3 ภาพ ชื่อภาพได้จากกล้องเรียงจากน้อยไปมาก

ชื่อภาพน้อยสุดไม่เอา เริ่มเอาภาพ ถัดไป 2 ภาพ
ต้องมาเปลี่ยนชื่อภาพซึ่งไม่ไหวเยอะมาก เพื่อให้สูตรทำงานตามเงื่อนไข

อยากทราบว่าท่านใดมีวิธีแก้ไขปัญหาของโจทย์นี้ไหมค่ะ
1.ต้องการเอาภาพที่ 2 และ 3 ถัดจากภาพที่มีเลขท้ายน้อยที่สุด ส่วนใหญ่การถ่ายภาพของทีมงานจะเป็นแบบนี้
2.ชื่อภาพจะไม่เหมือนกัน เพราะได้จากกล้องเลยต้องกำหนดเป็นภาพที่ 2 และ 3 ที่มีเลขมากเป็นอันดับ 2 และ 3 ค่ะ
3.กำหนดให้ VBA เลือกมาใส่เองอัตโนมัติจากเงื่อนไขเบี้องต้นค่ะ

ใครช่วยได้ช่วยทีนะค่ะ จะเป็นพระคุณอย่างสูงค่ะ

อรวีร์
29 Jun 2011, 18:02
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 ก่อนทดลองนะคะ

widtara
30 Jun 2011, 11:30
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
30 Jun 2011, 11:31
ไม่แน่ใจว่าทำได้หรือยัง แต่ผมอยากเพิ่มเติมครับ ลองเอาตัวอย่างที่ผมใช้งานอยู่ไปประยุกต์ดูนะครับว่าตรงกับที่ต้องการหรือป่าว โดยที่ผมทำคือจะให้ใส่ชื่อก่อน แล้วคลิกเลือกที่ 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
30 Jun 2011, 12:00
ขอโทษครับเนื่องจาก File มีขนาดใหญ่ ไม่สามารถ Upload ได้ผมขอแนบ File รูปตัวอย่างแทนนะครับ

widtara
30 Jun 2011, 13:37
ขอโทษครับเนื่องจาก 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
30 Jun 2011, 13:58
1.jpg ต้องไปกำหนดชื่อภาพใน Folders ให้มีชื่อเป็น 1
ภาพเดิมมีตัวเลขท้ายๆที่มากกว่าเป็นอันดับ 1 เช่น DSC079323

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


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

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

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

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

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

อรวีร์
30 Jun 2011, 22:13
ทดลอง 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

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

widtara
1 Jul 2011, 09:50
โปรแกรมที่เปลี่ยนชื่อแฟ้มใน 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

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

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

วิธีเรียกใช้
RenameInFolder "R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES TOP LOAD\wk26\RJ LT\105980"
อย่าลืม Backup file ก่อนทดลองนะคะ

ช่วยตรวจ code ให้หน่อยค่ะ อ้อยใส่ถูกที่หรือเปล่าค่ะ
เพราะคิดว่า C43 คือ R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk01\RJ ID\88004\1.jpg

และ L43 คือ R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk01\RJ ID\88004\2.jpg

RenameInFolder("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
RenameInFolder("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"


รันแล้ว Error ค่ะ

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

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"
RenameInFolder Cells(44, 3).Value
On Error Resume Next


คือตอนแรกอ้อยไม่เข้าใจข้อความตรงนี้ค่ะ
ถ้าชื่อ Folder อยู่ใน Cell D2 ก็ใช้ Code
RenameInFolder Cells( 2 , 4 ).Value


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


ก็เลยมานั่งแกะดูว่ามันหมายความว่าอย่างไร เลยสังเกตุว่า D2 ทำไมถึงได้ค่อเป็น Cells(2,4) อ้อยเลยลองนับแถวและ คอลัมน์ดูค่ะ เลยพบว่า 2 คือบรรทัดที่ 2 และ 4 คือ แถวที่ 4 เพราะนับจาก
(1= A),(2 = B), (3= C),(4=D)

เลยกำหนดให้ช่อ C44 ==D114&"\"&D115&"\"&D116&"\"&D117&"\"&D118&"\"ซึ่งจะได้ค่ะเป็น
R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk01\RJ ID\88004\

พอดี เพราะตอนแรกอ้อยดึงจาก ช่อง C43 ที่ได้ค่ะเป็น
R:\SQA DEDUCT PAYMENT Y11\EVENT PICTURES DRYER\wk01\RJ ID\88004\1.jpg

จากนั้นก็กำหนดให้
RenameInFolder Cells(44, 3).Value
คือบรรทัดที่ 44 ช่องที่ 3 คือ คอลัมน์ C นั้นเอง


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

ต้องขอบอกไว้ก่อนว่าอ้อยเองก็แปลความหมายของสูตร หรือว่าต้องเอาไปวางไว้ตรงไหนของสูตรเดิม

ปัญหาหลักๆของอ้อยอยู่ตรงนี้อ้อยค่ะ

ถึงตอนนี้ก็เริ่มไล่ code ได้บ้างแล้ว และก็พึ่งทราบว่า Ceels(44,3).Value มันบอกตำแหน่งบรรทัด และ คอลัมน์ใน ไฟล์ excel นั้นเอง

ขอขอบคุณทุกความช่วยเหลือนะค่ะ ตอนนี้สามารถทำงานได้แบบเลื่อนไหล สบายอุราที่สุดเลยค่ะ
อยากบอกว่า เริ่มจะรัก VBA มากขึ้นแล้วละ:biggrin:

excel_fever
1 Jul 2011, 14:56
งานนี้สำเร็จด้วยความพยายามของตัวเองซะส่วนใหญ่ ขนาดบอกว่าไม่เป็น VBA นะเนี่ย

widtara
1 Jul 2011, 15:47
งานนี้สำเร็จด้วยความพยายามของตัวเองซะส่วนใหญ่ ขนาดบอกว่าไม่เป็น VBA นะเนี่ย

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

ส่วนของอ้อยเมื่อเขียน code ที่ดีๆสำเร็จแล้วก็จะ Export ไฟล์ ไว้ใช้ค่ะ เนื่องจากว่าทำใน เครื่องเป็น 2007 ซึ่งรวบรวม error แบบไม่ทราบสาเหตุ เวลาอ้อยรัน ต้อง ปิดใหม่เปิดใหม่บ่อยมาก ไม่รู้ว่า 2007 เนี้ยเป็นอะไรของเขามากนะ error ได้ตลอดทั้งที่ code ถูกนะค่ะ พอปิด แล้วเปิดใหม่มาทำอีกยังได้เลย งง ๆ:nonod:

งานชิ้นโบร์แดงถัดไปจะทำการ modify data INVENTORY TRACKING ของตัวเองใหม่โดยมีต้นแบบของอาจารย์เป็นต้นแบบค่ะ แต่ไฟล์อาจารย์ก็แกะ code แล้วมึนหัวเอาเรื่องเลย

คิดว่าจะต่อกระทู้เดิมหรือเปิดกระทู้ใหม่สำหรับเรื่องใหม่ดีค่ะ แต่ก็มี VBA เป็นพระเอกเหมือนเดิมค่ะ
:confused:

ขอบคุณทุกคนที่ให้ความช่วยเหลือนะค่ะ ซึ้งใจจริงๆ:type::smile:

orange_soi9
1 Jul 2011, 15:54
ขอชื่นชมเช่นกันค่ะ นี่แหละถ้าลองทำและคิดด้วยตัวเอง ก็จะเป็นเรียนรู้ไปในตัวด้วยค่ะ :smile:

excel_fever
1 Jul 2011, 16:28
-ใช้ Macro Recorder บันทึกการกระทำใด ๆ แล้วเอารหัสนั้นมาแต่ง
-ลักจำของคนอื่น

widtara
1 Jul 2011, 16:29
ขอชื่นชมเช่นกันค่ะ นี่แหละถ้าลองทำและคิดด้วยตัวเอง ก็จะเป็นเรียนรู้ไปในตัวด้วยค่ะ :smile:

ตอนนี้เริ่มมองหาหนังสือที่จะเข้ากับเราแล้วค่ะ
http://www.se-ed.com/TextBook/Quotation/Products/Search.aspx?search=author&keyword=WALKENBACH, JOHN

1. Excel 2007 Power Programming with VBA (http://www.excelexperttraining.com/TextBook/Quotation/Products/Detail.aspx?No=9780470044018)
9780470044018
ผู้เขียน John Walkenbach 2,250.00 บาท

2.
Excel VBA Programming for Dummies
9780764574122
-
ผู้เขียน John Walkenbach 900 บาท

ผู้เขียนเขาว่าดี

ใครมีแล้วไม่ใช้แล้วขายต่อให้อ้อยได้นะค่ะ เสียดายหนังสือ หรือว่าใครไปเจอที่ดีๆ แนะนำหน่อยนะค่ะ ยอมรับว่าใหม่จริงกับเรื่องนี้ ยังมีอีกหลายความมึนงง ที่อธิบายไม่ถูก คงได้มีอะไรยุ่งอยากมาให้ช่วยอีกเป็นแน่ แต่ 3 อาทิตย์มานี้ สมองบวมแล้วค่ะ ถือว่า 2 อาทิตย์ที่เต็มที่เลย เพราะอาทิตย์ที่แล้วไปเรียนกับอาจารย์มา ขนาดนั่งแถวหน้า ความมึนงง ก็ยังคงอยู่ไม่ไปไหน ก็เลยไม่ได้มาไล่แก้ไขตรงนี้ ยอมรับมาปวดหัวมากขนาดเอาไปฝันเลย ตอนที่รัน code ไม่ได้ เรื่องจริงนะค่ะเนี้ย
เป็นเอามากจริงๆ

orange_soi9
1 Jul 2011, 16:34
1. Excel 2007 Power Programming with VBA (http://www.excelexperttraining.com/TextBook/Quotation/Products/Detail.aspx?No=9780470044018)
9780470044018
ผู้เขียน John Walkenbach 2,250.00 บาท

2.
Excel VBA Programming for Dummies
9780764574122
-
ผู้เขียน John Walkenbach 900 บาท
ส้มมีเป็น Ebook ทั้ง 2 เล่มเลย สนใจไหมคะ ถ้าสนใจเดี๋ยวส่งให้เลยค่ะ :smile:

widtara
1 Jul 2011, 16:50
ส้มมีเป็น Ebook ทั้ง 2 เล่มเลย สนใจไหมคะ ถ้าสนใจเดี๋ยวส่งให้เลยค่ะ :smile:

:type:ชื่นชมคนเก่งอย่างคุณส้มอยู่แล้วยิ่งได้ของเดิมที่เคยให้ความรู้คุณส้มมายิ่งดีใจเลย

excel_fever
1 Jul 2011, 16:53
ผมเข้าใจอะไรผิดหรือเปล่า
Ebook นี่เขาไม่ส่งกันทาง Email หรือครับ

widtara
1 Jul 2011, 16:57
ผมเข้าใจอะไรผิดหรือเปล่า
Ebook นี่เขาไม่ส่งกันทาง Email หรือครับ

ตายละ ซื่อบื่อไม่บันยะบันยัง อะไรเลยเรา นึกว่าเป็นเล่ม :nonod: ขอโทษทีค่ะงั้นเปลี่ยนที่อยู่เลยแล้วกันค่ะ

widtara.khumket@electrolux.com นะค่ะ ใช้ทุกวัน
CC. supitsara.p@hotmail.com นะค่ะ เปิดที่บ้านได้ค่ะ

ขอบคุณค่ะ

ขายหน้าจริงๆเลยเรา:confused:

orange_soi9
1 Jul 2011, 17:16
ตายละ ซื่อบื่อไม่บันยะบันยัง อะไรเลยเรา นึกว่าเป็นเล่ม :nonod: ขอโทษทีค่ะงั้นเปลี่ยนที่อยู่เลยแล้วกันค่ะ

widtara.khumket@electrolux.com นะค่ะ ใช้ทุกวัน
CC. supitsara.p@hotmail.com นะค่ะ เปิดที่บ้านได้ค่ะ

ขอบคุณค่ะ

ขายหน้าจริงๆเลยเรา:confused:
พอดี Up Files ให้แล้ว รบกวนไป Download เอาก็แล้วกันนะคะ :smile:

widtara
2 Jul 2011, 00:57
พอดี Up Files ให้แล้ว รบกวนไป Download เอาก็แล้วกันนะคะ :smile:

คลิกตรงไหนค่ะของ ลิงค์หน่อยค่ะ :yesnod:

widtara
14 Nov 2011, 14:22
พื้นที่ที่จะแทรกภาพ เป็นแนวตั้ง แต่ภาพเป็นแนวนอน ย่อหรือขยายแล้วก็ผิดรูปร่าง แถมภาพนั้น Dimension อาจใหญ่มาก ๆ ถึงจะย่อลงแล้วก็ยังไม่ได้ Compress ทำให้ไฟล์มีขนาดใหญ่ตามไปด้วย ผมถึงได้บอกให้แต่งภาพก่อนไงครับ

ส่วนที่บอกว่าแปล Code ไม่ออกนั้นให้ลองเปิดไฟล์ที่ได้จากการแยกชีต (ที่ผมแนบไปให้) ดูที่เซลล์ C43 กับ L43 จะเป็นสูตรอยู่ นั่นแหละครับคือสูตรที่ได้จากบรรทัด Selection.FormulaR1C1=......

คือว่าเปลี่ยนช่องดึงภาพใหม่แล้วไม่รู้จะเขียนโค้ดใหม่ยังไงช่วยดูให้หน่อยค่ะ
Selection.FormulaR1C1 = "=R[71]C[-8]&""\""&R[72]C[-8]&""\""&R[73]C[-8]&""\""&R[74]C[-8]&""\""&R[75]C[-8]&""\""&R120C4"


โดยต้องการดึงมา 4 ภาพ

ตรงนี้นะค่ะ งงมาก ไม่รู้จะเปลี่ยนยังไง
มีไฟล์แนบมาให้ดูค่ะ
แล้วต้องการแก้คำสั่งให้ดึงภาพชื่อว่า 1,2,3,4 มาใส่ตามช่องที่ระบุ

ช่วยดูให้หน่อยค่ะ

excel_fever
14 Nov 2011, 18:24
ผมลืมวิธีการหมดแล้ว จำได้แค่หลักการ
คือการแทรกภาพนั้น ภาพจะถูกแทรกที่เซลล์ที่ถูกเลือกดังนั้น (สมมุติ)
Range("A1").select คือสั่งให้เลือกเซลล์ A1

Selection.formular1c1=.... คือสั่งให้เขียนสูตรเพื่อดึงภาพ

หลังจากนั้นจึงเป็นคำสั่งแทรกภาพโดยใช้ชื่อและ Path ของ Selection.value ซึ่งก็คือ A1

แต่ครั้งนี้คุณไม่ได้สั่งให้เซลล์เขียนสูตร (หรือไม่) แต่เป็นการพิมพ์ลงไป
อาจต้องเปลี่ยนเป็น

ภาพที่1
Range("D47:J71").select
ActiveSheet.Pictures.Insert(Range("C44:J44").value)
ภาพที่2
Range("L47:U71").select
ActiveSheet.Pictures.Insert(Range("L44:V44").value)
ภาพที่3
Range("D73:J97").select
ActiveSheet.Pictures.Insert(Range("C45:L45").value)
ภาพที่4
Range("L73:U97").select
ActiveSheet.Pictures.Insert(Range("L45:V45").value)

ปล. ย้ำว่าเป็นแนวทางครับ ผมไม่ได้ทดสอบ
น้ำท่วมบ้านไม่ได้ทำงาน ฝีมือตกไปเยอะครับ