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

[widtara]

ให้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.มีไฟล์ .xlsm ประกอบ ชื่อ AddPic
ถามว่าจะต้องเพิ่ม code ต่อจาก code ที่มีอย่างไรบ้างค่ะ

[widtara]

แนบภาพที่เหลือ 3-5

[widtara]

แนบภาพที่เหลือ 6,8,9

[snasui]

ผมเปิดไฟล์แล้วไม่พบ Code ลองเขียน Code มาก่อน ติดตรงไหนค่อยมาช่วยกันดูต่อครับ

[widtara]

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

[widtara]

ตอนนี้ไฟล์ที่แนบมาสามารถดึงภาพมาได้ แต่ติดปัญหาคือต้องการให้อยู่ในตำแหน่ง และ ปรับขนาดภาพลง

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

Insert Picture & Auto Size To Active Cell Dimmensions

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

[snasui]

ดูตัวอย่างที่นี่ครับ http://snasui.blogspot.com/2011/05/folder-excel.html

[widtara]

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

อาจารย์ค่ะ ในไฟล์ AddPic.xlsm มี 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

อ้อยเอามาผสมกันไม่เป็นค่ะ คือ อาจารย์ช่วยดูให้หน่อยค่ะ
เพื่อให้ได้ผลเป็นไฟล์ RJI-T1104-01-01FOSHAN WELLING WASHER MOTOR(VMI).xls ผลลัพธ์นี้ติดเรื่อง ตำแหน่งของภาพ กับทำขนาดภาพให้เล็กลงมาอีกนิดหนึ่งค่ะ

[snasui]

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

[widtara]

มีไฟล์ตัวอย่างให้โหลดดูไหมค่ะ คืองานอ้อยไม่ได้เขียนให้มีปุ่มนะค่ะ

[snasui]

ปุ่มกดเพียงเพื่อสั่งให้โปรแกรมทำงานเท่านั้น จะกำหนดให้มีหรือไม่ก็ได้ ไม่ได้เป็นสาระสำคัญครับ เราสามารถเพิ่มเข้าไปใน Code ที่สั่งจากคำสั่งอื่นได้ เช่น สั่งให้ Copy Sheet, นำภาพมาแสดง, จัดเก็บไฟล์ ไปในคราวเดียวกันก็ทำได้

สำหรับตัวอย่างไฟล์ที่คล้าย ๆ กันดูที่นี่ครับ http://www.snasui.com/viewtopic.php?f=3&t=324

[widtara]

ตอนนี้สามารถดึงภาพมาได้ดีแล้วค่ะ และจะทำการเปลี่ยนชื่อไฟล์ภาพอัตโนมัติแต่ติดปัญหา รัน Code แล้วไม่ทำงาน อาจารย์ช่วยเช็ค code ให้หน่อยค่ะ
Code ที่รันไม่ทำงานคือ 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

'Code ส่วนที่ 2 ทำงานได้ดีค่ะ
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

[widtara]

ภาพที่อยู่ของภาพค่ะ

[snasui]

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

[widtara]

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

ตอนนี้ที่ งงๆ อยู่คือ คำสั่ง RenameInFolder เอาไปใช้ไม่เป็นนะค่ะ

[snasui]

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

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

ขอถามเล่น ๆ แล้วกันครับ คุณ widtara สามารถเขียนชื่อ "คนควน" หรือ "snasui" ในฟอรัมอื่นแล้วแสดงผลถูกต้องนอกจากที่นี่หรือไม่ครับ

เรื่องการตอบคำถามเป็นลักษณะเฉพาะบุคคลครับ ผมอาจจะเขียนอธิบายให้เข้าใจได้ง่ายกับบางคน แต่อีกหลายคนก็ไม่เข้าใจก็เป็นได้ กรณีคุณ widtara มีคำถามแล้วได้รับคำอธิบายมาแล้วไม่เข้าใจ ก็ควรถามต่อกับผู้ที่ตอบมาครับ

[widtara]

ค่ะ คนที่ช่วยตอบอาจยุ่งๆอยู่ ดิฉันเลขนั่งแกะ Code และพยายามวางไว้จุดนั้นจุดนี้ ดูและทบทวนคำที่เขาบอก บางทีดิฉันก็ไม่เข้าใจเพราะมันอาจเป็นความหมายง่ายๆ แต่ไปต่อไม่เป็นเลย
ส่วนคำสั่งนี้อ้อยรันสำเร็จแล้ว เพราะตอนนั้นไม่ทราบว่าเราตำแหน่งในไฟล์เป็นตัวเลขแบบนี้ได้ ชินกับการเรียกว่า C44 พอมาเจอว่าข้อมูลของเราอยู่ C44 มันสามารถใช้ 44,3 ได้
RenameInFolder Cells(44, 3).Value
ก็นั่งไล่ดูจากตัวอย่างว่า ถ้าอยู่ D2 ก็ให้ใส่ 2,4 แทน ก็เลยเดาได้ว่ามันต้องเป็นแบบนี้ เลยลองทำดู และได้แจ้งผลลัทธ์ให้กับผู้ที่ช่วยเหลือแล้วค่ะ

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

บางคำตอบคนที่เก่งๆที่เข้าใจ code ง่ายก็แปลได้เร็ว แต่ดิฉันพึ่งศีกษา และยังงงๆอยู่
ที่สำคัญดิฉันจะ ไม่ค่อยเข้าใจว่าต้องวางคำสั่งไหนก่อน หรือหลังคำสั่งไหน ค่ะ

อาจารย์พอจะมีหนังสือแนะนำที่อ่านเข้าใจเรื่อง VBA ง่ายๆไหมค่ะ เคยไปหาซื้อไม่เจอเลยค่ะ มีแต่สอน excel ทั่วๆไปค่ะ

[snasui]

ตอบเรื่องหนังสือนะครับ

เนื่องจากผมไม่ได้อ่านหนังสือไทย ก็เลยไม่สามารถแนะนำได้ครับ หลัก ๆ แล้วผมอ่านจาก Help ของโปรแกรม ตำราต่างประเทศ เวบบอร์ดต่างประเทศ จากนั้นก็ทดสอบทดลองเอง เวบที่น่าสนใจสามารถดูได้ที่นี่ครับ http://www.mvps.org/links.html#Excel

สำหรับตำราต่างประเทศที่น่าสนใจตามด้านล่าง

Excel 2007 VBA Programming for Dummies <== เนื้อหาเน้นผู้เริ่มต้น
Excel 2010 Power Programming with VBA
Excel 2007 VBA Programmer's Reference
Professional Excel development
Microsoft Excel VBA Professional Projects

[widtara]

ขอบคุณมากค่ะอาจารย์ตอนนี้เห็นราคาแล้วค่ะ
http://www.se-ed.com/TextBook/Quotation ... CH,%20JOHN

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

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

ขอบคุณอาจารย์มากค่ะสำหรับคำแนะนำดีๆที่ให้มาค่ะ