VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

aueijung · #1

เรียนอาจารย์ครับ จะเขียน VBA อย่างไร เมื่อ i=3
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell N3 เข้าไปที่ชีท Home ลง Cell C9
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell O3 เข้าไปที่ชีท Home ลง Cell C10
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell P3 เข้าไปที่ชีท Home ลง Cell C11
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell Q3 เข้าไปที่ชีท Home ลง Cell C12
เสร็จ 1 ไฟล์ที่สร้างเสร็จ ข้อมูลต้องตรงกันในแถวนั้นๆ
พอสร้างไฟล์ต่อไปก็ เพิ่มให้เพิ่มค่า i
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell N4 เข้าไปที่ชีท Home ลง Cell C9
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell O4 เข้าไปที่ชีท Home ลง Cell C10
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell P4 เข้าไปที่ชีท Home ลง Cell C11
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell Q4 เข้าไปที่ชีท Home ลง Cell C12
เสร็จ 1 ไฟล์ที่สร้างเสร็จ ข้อมูลต้องตรงกันในแถวนั้นๆ
พอสร้างไฟล์ต่อไปก็ เพิ่มให้เพิ่มค่า i
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell N5 เข้าไปที่ชีท Home ลง Cell C9
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell O5 เข้าไปที่ชีท Home ลง Cell C10
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell P5 เข้าไปที่ชีท Home ลง Cell C11
ให้นำข้อมูลเข้าที่ชีท copyrenamefiles Cell Q5 เข้าไปที่ชีท Home ลง Cell C12
ทำแบบที่กล่าวมาไปเรื่อย ฯ จนกว่าสร้างไฟล์เสร็จ
(ข้อมูลที่นำไปใส่ที่ชีท Home ต้องเป็นข้อมูลในแถวที่สร้างไฟล์ จากชีท copyrenamefiles (คอลัมภ์ N,O,P,Q))

VAB เป็นดังนี้ครับ Directory คือ D\:ปพ.5\ปีการศึกษา2562\มัธยม\เทอม2\

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

snasui · #2

Code อยู่ในไฟล์ไหนอธิบายมาด้วยครับ

aueijung · #3

Code อยู่ในไฟล์ Copy-Rename-Files-ม.1-3-Term2-62.xlsm ในชีท copyrenamefiles ครับ
โดยการคลิกที่ปุ่ม CopyDataRenameFiles (สร้างไฟล์ได้สำเร็จครับอาจารย์) แต่ไม่สามารถนำข้อมูลใน
ชีท copyrenamefiles ที่เซลล์ N3 คัดลอกไปไฟล์ที่สร้างใหม่คือ ท21102-1.xlsm ในชีท Home ที่เซลล์ C9
ชีท copyrenamefiles ที่เซลล์ O3 คัดลอกไปไฟล์ที่สร้างใหม่คือ ท21102-1.xlsm ในชีท Home ที่เซลล์ C10
ชีท copyrenamefiles ที่เซลล์ P3 คัดลอกไปไฟล์ที่สร้างใหม่คือ ท21102-1.xlsm ในชีท Home ที่เซลล์ C11
ชีท copyrenamefiles ที่เซลล์ Q3 คัดลอกไปไฟล์ที่สร้างใหม่คือ ท21102-1.xlsm ในชีท Home ที่เซลล์ C12
ตามลำดับ

และเมื่อคัดลอกข้อมูลเสร็จแล้ว ก็ให้ดูไฟล์ที่สร้างขึ้นมาใหม่ในลำดับถัดไป ให้นำข้อมูลใน
ชีท copyrenamefiles ที่เซลล์ N4 คัดลอกไปใส่ไฟล์ใหม่คือ ค21102-1.xlsm ในชีท Home ที่เซลล์ C9
ชีท copyrenamefiles ที่เซลล์ O4 คัดลอกไปใส่ไฟล์ใหม่คือ ค21102-1.xlsm ในชีท Home ที่เซลล์ C10
ชีท copyrenamefiles ที่เซลล์ P4 คัดลอกไปใส่ไฟล์ใหม่คือ ค21102-1.xlsm ในชีท Home ที่เซลล์ C11
ชีท copyrenamefiles ที่เซลล์ Q4 คัดลอกไปใส่ไฟล์ใหม่คือ ค21102-1.xlsm ในชีท Home ที่เซลล์ C12

และพอเสร็จไฟล์ที่ 2 ก็เริ่มไฟล์ที่ 3
ชีท copyrenamefiles ที่เซลล์ N5 คัดลอกไปใส่ไฟล์ใหม่คือ ว21102-1.xlsm ในชีท Home ที่เซลล์ C9
ชีท copyrenamefiles ที่เซลล์ O5 คัดลอกไปใส่ไฟล์ใหม่คือ ว21102-1.xlsm ในชีท Home ที่เซลล์ C10
ชีท copyrenamefiles ที่เซลล์ P5 คัดลอกไปใส่ไฟล์ใหม่คือ ว21102-1.xlsm ในชีท Home ที่เซลล์ C11
ชีท copyrenamefiles ที่เซลล์ Q5 คัดลอกไปใส่ไฟล์ใหม่คือ ว21102-1.xlsm ในชีท Home ที่เซลล์ C12

ทำไปจนครบทุกไฟล์ครับผม

การวางโฟลเด้อทำดังนี้ครับ แตกไฟล์ Zip ปพ.5.rar ไปวางที่ไดร์ฟ D:\
จะได้ directory ดังนี้ครับ D:\ปพ.5\ปีการศึกษา2562\มัธยม\เทอม2
ในไดร์ฟ D:\ปพ.5\ปีการศึกษา2562 จะเป็นดังนี้ครับ
1. มีไฟล์ Copy-Rename-Files-ม.1-3-Term2-62.xlsm (ซึ่งเป็นไฟล์ที่มีไว้เพื่อสร้างไฟล์ใหม่ และคัดลอกข้อมูลเข้าไฟล์ที่สร้างขึ้นมา)
2. มีไฟล์ m.1-3T2.xlsm เป็นต้นฉบับ เพื่อเอาไว้เป็นสำเนาให้ข้อ 1. สร้างครับ

ปล.ภายในโฟล์เด้อ ...\เทอม2 จะมีโฟล์เด้อย่อย เพื่อเป็นที่เก็บไฟล์ที่สร้างใหม่ ตามการอ้างอิงของไฟล์ Copy-Rename-Files-ม.1-3-Term2-62.xlsm ที่ ชีท copyrenamefiles คอลัมภ์ D ถูกจัดเก็บไว้เป็นหมวดหมู่

snasui · #4

Code นี้เป็นการ Loop ด้วย For...Next โดยมีค่า r ให้ใช้เพื่อระบุตำแหน่งที่สัมพันธ์กับค่า r ไปวางยังปลายทาง จึงไม่จำเป็นต้องเขียนตัวแปร i เพื่อเก็บค่าบรรทัดถัดไปแต่อย่างใดครับ

ตัวอย่างการปรับ Code และการเยื้อง 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

สังเกตว่า if กับ End If ต้องวางให้ตรงกัน With กับ End With จะต้องตรงกัน For กับ Next จะต้องตรงกัน

นอกจากนี้กรุณาสังเกตการใช้ With...End With เพื่อความกระชับของ Code จากที่ผมปรับมาให้ว่าเป็นการใช้ในลักษณะใด

aueijung · #5

ขอบพระคุณมากครับอาจารย์ ความรู้จากข้อความ

สังเกตว่า if กับ End If ต้องวางให้ตรงกัน With กับ End With จะต้องตรงกัน For กับ Next จะต้องตรงกัน
นอกจากนี้กรุณาสังเกตการใช้ With...End With เพื่อความกระชับของ Code จากที่ผมปรับมาให้ว่าเป็นการใช้ในลักษณะใด

ได้รับความเข้าใจเพิ่มขึ้นอีกระดับ จากที่ไม่เคยใช้ With กับ End With ยอดเยี่ยมมากครับอาจารย์

aueijung · #6

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

หากต้องการให้ เมื่อใส่ข้อมูลเข้า ชีท Home แล้ว
.
.
.
' เพิ่มข้อมูลเข้าชีท 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
.
.
.
โดยให้ทำการล็อค Cell C9,C10,C11,C12 เพื่อไม่ให้ผู้ใช้แก้ไข CELL ดังกล่าว เมื่อสร้างไฟล์เสร็จ ต้องใช้คำสั่งอย่างไรครับอาจารย์

snasui · #7

การ Lock เพื่อไม่ให้แก้ไขได้จะใช้การ Protect Sheet แล้วใส่ Password เข้ามาช่วยครับ

หลักการทำงานด้วย Code คือเมื่อจะทำงานใดให้ปลด Lock แล้วทำงาน เมื่อเสร็จงานก็ให้ Lock ไว้เหมือนเดิมครับ

aueijung · #8

จากที่อาจารย์กล่าวมานั้น ผมทำตามได้ดังนี้

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

ถ้าเราจะซ่อนไม่ให้แสดง รหัสผ่าน .Unprotect Password:="xxxx" และ .Protect Password:="xxxx" คือไม่ให้ผู้ใช้เห็นรหัสผ่านมีวิธีการปิดหรือไม่ครับผม

snasui · #9

การซ่อนรหัสใน Code จะต้องทำผ่านเมนู Tools > VBA Project Properties > กรอก Password ที่แถบ Protection ของหน้าต่าง VBE ครับ

Excel Forum

EXCEL TOOLS

VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)

Re: VBA : ดึงข้อมูลใส่ให้ตรงกับไฟล์ที่กำลังสร้างใหม่ (ตามชื่อไฟล์ = รหัสวิชา)