ตรวจสอบและปรับปรุงไฟล์ Excel ให้เร็วและเสถียรด้วย File Anatomy Add-in
เครื่องมือนี้ช่วยวิเคราะห์โครงสร้างไฟล์อย่างละเอียด เช่น สูตร, ลิงก์, PivotTable, Styles และ Objects
พร้อมฟังก์ชันล้างสิ่งเกินจำเป็นที่ทำให้ไฟล์ช้า หรือเสียหายได้ในคลิกเดียว
เหมาะสำหรับผู้ใช้ Excel ที่ต้องการควบคุมคุณภาพไฟล์อย่างมืออาชีพ
ทดลองใช้ Add-in
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
ระบุ Version ของ Excel 
โปรดทราบ สมัครสมาชิก
Login ผ่าน Facebook Reset รหัสผ่าน ติดต่อผู้ดูแลระบบ ตั้งค่าส่วนตัว วิธีการตั้งและตอบกระทู้ จัดรูปแบบตัวอักษร กำหนดขนาดตัวอักษรใน Browser
คำแสดงเจตนา[code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)
Code: Select all
Sub CopyDataRenameFiles()
Dim src As String, dst As String, fl As String
Dim rfl As String, rall As Range, r As Range
Dim directory As String, fileName As String, room As String
Dim sheet As Worksheet, j, i As Integer
Dim tempBook As Workbook, thsBook As Workbook
Set thsBook = ThisWorkbook
With ActiveSheet
'Source directory ไดร์ฟปลายทาง
src = .Range("B3").Value
'Destination directory
'dst = Range("D3")
'File name
fl = .Range("B6").Value
'Rename file
' rfl = Range("F3")
Set rall = .Range("d3", .Range("d" & .Rows.Count).End(xlUp))
' On Error Resume Next
Application.ScreenUpdating = False
For Each r In rall
dst = r.Value
rfl = r.Offset(0, 2).Value
FileCopy src & fl, dst & rfl
Set tempBook = Workbooks.Open(fileName:=dst & rfl)
' tempBook.Sheets("นักเรียน").Range("c6:g60").Value = '_
' thsBook.Sheets(r.Offset(0, 4).Value).Range("b3:g57").Value
tempBook.Sheets("นักเรียน").Range("c6:c60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("b3:b57").Value
tempBook.Sheets("นักเรียน").Range("d6:d60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("g3:g57").Value
' tempBook.Sheets("นักเรียน").Range("d6:d60").NumberFormat = "0000000000000"
tempBook.Sheets("นักเรียน").Range("e6:e60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("c3:c57").Value
tempBook.Sheets("นักเรียน").Range("f6:f60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("d3:d57").Value
tempBook.Sheets("นักเรียน").Range("g6:g60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("e3:e57").Value
' นำข้อมูลเข้าที่ชีท copyrenamefiles เข้าไปที่ชีท Home ของแต่ละไฟล์ที่สร้างเสร็จ
i = 3
If i = 3 Then
tempBook.Sheets("Home").Range("C9").Value = _
thsBook.Sheets("copyrenamefiles").Range("N" & i).Value
tempBook.Sheets("Home").Range("C10").Value = _
thsBook.Sheets("copyrenamefiles").Range("O" & i).Value
tempBook.Sheets("Home").Range("C11").Value = _
thsBook.Sheets("copyrenamefiles").Range("P" & i).Value
tempBook.Sheets("Home").Range("C12").Value = _
thsBook.Sheets("copyrenamefiles").Range("Q" & i).Value
End If
tempBook.Close True
If Err.Number <> 0 Then
MsgBox "Copy error: " & src & "\" & rfl
End If
Next r
i = i + 1
On Error GoTo 0
End With
Application.ScreenUpdating = True
' MsgBox ("สร้างไฟล์ข้อมูลเข้า Directory เรียบร้อยแล้ว")
End Sub
Code อยู่ในไฟล์ไหนอธิบายมาด้วยครับ Code นี้เป็นการ Loop ด้วย 
For...Next โดยมีค่า r ให้ใช้เพื่อระบุตำแหน่งที่สัมพันธ์กับค่า r ไปวางยังปลายทาง จึงไม่จำเป็นต้องเขียนตัวแปร i เพื่อเก็บค่าบรรทัดถัดไปแต่อย่างใดครับCode: Select all
Sub CopyDataRenameFiles()
Dim src As String, dst As String, fl As String
Dim rfl As String, rall As Range, r As Range
Dim directory As String, fileName As String, room As String
Dim sheet As Worksheet, j, i As Integer
Dim tempBook As Workbook, thsBook As Workbook
Set thsBook = ThisWorkbook
With ActiveSheet
'Source directory ไดร์ฟปลายทาง
src = .Range("B3").Value
'Destination directory
'dst = Range("D3")
'File name
fl = .Range("B6").Value
'Rename file
' rfl = Range("F3")
Set rall = .Range("d3", .Range("d" & .Rows.Count).End(xlUp))
' On Error Resume Next
Application.ScreenUpdating = False
For Each r In rall
dst = r.Value
rfl = r.Offset(0, 2).Value
FileCopy src & fl, dst & rfl
Set tempBook = Workbooks.Open(fileName:=dst & rfl)
With tempBook.Sheets("นักเรียน")
.Range("c6:c60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("b3:b57").Value
.Range("d6:d60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("g3:g57").Value
.Range("e6:e60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("c3:c57").Value
.Range("f6:f60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("d3:d57").Value
.Range("g6:g60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("e3:e57").Value
End With
' เพิ่มข้อมูลเข้าชีท Home
With tempBook.Sheets("Home")
.Range("C9").Value = r.Offset(0, 10).Value
.Range("C10").Value = r.Offset(0, 11).Value
.Range("C11").Value = r.Offset(0, 12).Value
.Range("C12").Value = r.Offset(0, 13).Value
End With
tempBook.Close True
If Err.Number <> 0 Then
MsgBox "Copy error: " & src & "\" & rfl
End If
Next r
On Error GoTo 0
End With
Application.ScreenUpdating = True
' MsgBox ("สร้างไฟล์ข้อมูลลง Directory เรียบร้อยแล้ว")
End Sub
if กับ End If ต้องวางให้ตรงกัน With กับ End With จะต้องตรงกัน For กับ Next จะต้องตรงกันWith...End With เพื่อความกระชับของ Code จากที่ผมปรับมาให้ว่าเป็นการใช้ในลักษณะใดCode: Select all
Sub CopyDataRenameFiles()
Dim src As String, dst As String, fl As String
Dim rfl As String, rall As Range, r As Range
Dim directory As String, fileName As String, room As String
Dim sheet As Worksheet, j, i As Integer
Dim tempBook As Workbook, thsBook As Workbook
Set thsBook = ThisWorkbook
With ActiveSheet
'Source directory ไดร์ฟปลายทาง
src = .Range("B3").Value
'Destination directory
'dst = Range("D3")
'File name
fl = .Range("B6").Value
'Rename file
' rfl = Range("F3")
Set rall = .Range("d3", .Range("d" & .Rows.Count).End(xlUp))
' On Error Resume Next
Application.ScreenUpdating = False
For Each r In rall
dst = r.Value
rfl = r.Offset(0, 2).Value
FileCopy src & fl, dst & rfl
Set tempBook = Workbooks.Open(fileName:=dst & rfl)
With tempBook.Sheets("นักเรียน")
.Range("c6:c60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("b3:b57").Value
.Range("d6:d60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("g3:g57").Value
.Range("e6:e60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("c3:c57").Value
.Range("f6:f60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("d3:d57").Value
.Range("g6:g60").Value = _
thsBook.Sheets(r.Offset(0, 4).Value).Range("e3:e57").Value
End With
' เพิ่มข้อมูลเข้าชีท Home
With tempBook.Sheets("Home")
.Range("C9").Value = r.Offset(0, 10).Value
.Range("C10").Value = r.Offset(0, 11).Value
.Range("C11").Value = r.Offset(0, 12).Value
.Range("C12").Value = r.Offset(0, 13).Value
End With
tempBook.Close True
If Err.Number <> 0 Then
MsgBox "Copy error: " & src & "\" & rfl
End If
Next r
On Error GoTo 0
End With
Application.ScreenUpdating = True
' MsgBox ("สร้างไฟล์ข้อมูลลง Directory เรียบร้อยแล้ว")
End Sub
Code: Select all
' เพิ่มข้อมูลเข้าชีท Home
With tempBook.Sheets("Home")
.Range("C9").Value = r.Offset(0, 10).Value
.Range("C10").Value = r.Offset(0, 11).Value
.Range("C11").Value = r.Offset(0, 12).Value
.Range("C12").Value = r.Offset(0, 13).Value
.Unprotect Password:="xxxx"
.Range("C9:C12").Locked = True
.Protect Password:="xxxx"
End With