Coppy sheet พร้อมกับ Insert picture รูปเก่ายังติดมา macro
Posted: Mon Apr 28, 2014 9:24 am
ผมมี sheet list ที่เก็บ ID องหลายๆคนไว้
และ sheet test เป็นต้นแบบที่ต้อง coppy
ใช้ macro โดยชื่อของ sheet ใหม่จะเป็น ID และ Insert picture (จาก folder ชื่อรูปเป็น ID)ไปพร้อมๆกัน ส่วนชื่อ picture ก็เป็น ID เช่นกัน
ปัญหาก็คือ เมื่อ coppy sheet กับ insert picture รูปเก่าจะ เข้ามาด้วย เช่น คนที่ 2 มี รูป 1 2 คนที่ 5 มีรูป 1 2 3 4 5 ทับกันอยู่
Sub coppySheet()
Dim i As Integer
Dim x As String 'x is ID
For i = 1 To 5 'loop for create sheet
ActiveSheet.Copy Workbooks("Book1.xlsm").Worksheets("test") ' coppy pattern
x = Worksheets("list").Range("B" & i)
ActiveSheet.Name = x 'Name of this sheet
Worksheets(x).Range("C1") = Worksheets("list").Range("B" & i) 'sid
ActiveSheet.Pictures.Insert("C:\Users\ARt\Desktop\Pic\" & x & ".jpg").Select 'Path to where pictures are stored
With Selection 'Resize picture and point of picture
.Left = Range("p3").Left
.Top = Range("p3").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 130#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
End With
Next i
End Sub
หาโค้ดมาจาก http://en.kioskea.net/faq/6485-excel-a- ... t-pictures
และ sheet test เป็นต้นแบบที่ต้อง coppy
ใช้ macro โดยชื่อของ sheet ใหม่จะเป็น ID และ Insert picture (จาก folder ชื่อรูปเป็น ID)ไปพร้อมๆกัน ส่วนชื่อ picture ก็เป็น ID เช่นกัน
ปัญหาก็คือ เมื่อ coppy sheet กับ insert picture รูปเก่าจะ เข้ามาด้วย เช่น คนที่ 2 มี รูป 1 2 คนที่ 5 มีรูป 1 2 3 4 5 ทับกันอยู่
Sub coppySheet()
Dim i As Integer
Dim x As String 'x is ID
For i = 1 To 5 'loop for create sheet
ActiveSheet.Copy Workbooks("Book1.xlsm").Worksheets("test") ' coppy pattern
x = Worksheets("list").Range("B" & i)
ActiveSheet.Name = x 'Name of this sheet
Worksheets(x).Range("C1") = Worksheets("list").Range("B" & i) 'sid
ActiveSheet.Pictures.Insert("C:\Users\ARt\Desktop\Pic\" & x & ".jpg").Select 'Path to where pictures are stored
With Selection 'Resize picture and point of picture
.Left = Range("p3").Left
.Top = Range("p3").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 130#
.ShapeRange.Width = 100#
.ShapeRange.Rotation = 0#
End With
Next i
End Sub
หาโค้ดมาจาก http://en.kioskea.net/faq/6485-excel-a- ... t-pictures