คัดลอกไฟล์ แล้วสร้างไฟล์หลายๆ ชื่อ เพื่อนำใส่แต่ละโฟลเดอร์

[aueijung]

คำสั่ง VBA คัดลอกไฟล์ แล้วเปลี่ยนชื่อทีละหลายๆไฟล์ ตามรายชื่อไฟล์ที่กำหนด ใส่ในแต่ละโฟลเด้อ ต้องใช้คำสั่งอย่างไรครับ

[aueijung]

จากไฟล์ Copy-rename-files-excel-vba.xlsm ที่ ปุ่ม Copy and rename files ชีท Copy and rename files โดยมองที่ D3:D22 แล้วสร้างไฟล์ ให้ตรงตาม F3:F22 คำสั่ง VBA ต้องทำอย่างไรครับ

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

Sub CopyRenameFile()
    Dim src As String, dst As String, fl As String
    Dim rfl As String, rall As Range, r As Range
    
    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
        For Each r In rall
            dst = r.Value
            rfl = r.Offset(0, 2).Value
            FileCopy src & "\" & fl, dst & "\" & rfl
            If Err.Number <> 0 Then
                MsgBox "Copy error: " & src & "\" & rfl
            End If
        Next r
        On Error GoTo 0
    End With
End Su

[aueijung]

ใช้ได้ดีมากๆ ครับอาจารย์ ขอบคุณมากๆ ครับ:mrgreen:

[aueijung]

การคัดลอกข้อมูลจากชีท ป.1-1,ป.1-2,ป.1-3,ป.1-4 ที่ cell B3:G57 ของแต่ละชีท ไปวางในไฟล์ที่ คัดลอกและเปลี่ยนชื่อไฟล์ใส่ในแต่ละห้อง (ที่ชีท นักเรียน cell C6:G60) โดยคัดลอกข้อมูลนักเรียนไปใส่แต่ละไฟล์ให้ตรงชีท นักเรียน cell C6:G60 ชื่อไฟล์ใหม่ที่ถูกเปลี่ยนชื่อมาในแต่ละห้อง
ซึ่ง cell B3:G57 แต่ละชีท โดยสลับ เลขประจำตัวประชาชน ไปไว้ข้าง รหัสนักเรียน ดังจะได้ผลลัพธ์ดังนี้

ชีท ป.1-1 cell B3 วางที่ ชีท นักเรียน ที่ cell C6
ชีท ป.1-1 cell C3 วางที่ ชีท นักเรียน ที่ cell E6
ชีท ป.1-1 cell D3 วางที่ ชีท นักเรียน ที่ cell F6
ชีท ป.1-1 cell E3 วางที่ ชีท นักเรียน ที่ cell G6
ชีท ป.1-1 cell G3 วางที่ ชีท นักเรียน ที่ cell D6
จนครบทุกห้อง ป.1-1,ป.1-2,ป.1-3,ป.1-4

ทุกๆไฟล์จะมีข้อมูลนักเรียนของห้องนั้นๆ ตามไปอยู่ในแต่ละไฟล์ที่ถูกเปลี่ยนชื่อ (สร้างไฟล์ใหม่) พร้อมมีชื่อที่ตรงตามห้องที่ชีท นักเรียน จนครบตั้งแต่นักเรียนเลขที่ 1-55

เราจะต้องเขียนโค๊ด VBA คัดลอกข้อมูลอย่างไรครับ เพื่อใส่ข้อมูลให้ตรงชีท ตรงไฟล์ ตรงห้อง ของแต่ละห้องที่ควรมีชื่อนักเรียนอยู่ในแต่ละ Destination folder จนครบทุกห้อง

[snasui]

โพสต์ Code ที่เขียนมาเองแล้วลงในกล่องความเห็นนี้ด้วย พร้อมแจ้งว่าติดขัดที่บรรทัดใดครับ

[aueijung]

ส่งผิดไฟล์ครับ อาจารย์ปรับให้แล้วแต่บันทึกไปอีกไฟล์นึงครับ

[aueijung]

เราจะ copy ข้อมูลนักเรียน จากชีท ป.1-1, ป.1-2, ป.1-3, ป.1-4 ไปใส่ยังไฟล์ที่ rename ชื่อไฟล์ F3:F22 ตาม Destination folder ของแต่ละห้อง D3:D22 ได้อย่างไรครับ

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 As Integer
Dim tempBook As Workbook, thsBook As Workbook
    
    
    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
        For Each r In rall
            dst = r.Value
            rfl = r.Offset(0, 2).Value
            FileCopy src & "\" & fl, dst & "\" & rfl
            If Err.Number <> 0 Then
                MsgBox "Copy error: " & src & "\" & rfl
            End If
        Next r
        On Error GoTo 0
    End With
    
    Application.ScreenUpdating = False
    
    directory = Sheets("copyrenamefiles").Range("D3").Value
    fileName = Dir(directory & "*.xl??")
    room = Sheets("ป.1-1").Range("B3:G57").Value
    Set thsBook = ThisWorkbook
    j = j + 1
    Do While fileName <> ""
        Set tempBook = Workbooks.Open(directory & fileName)
        thsBook.Sheets("นักเรียน").Cells(3, j) = tempBook.Name
        thsBook.Worksheets("นักเรียน").Cells(3, j).Resize(60, 6).Value = _
            tempBook.Sheets(room).Range("C6:G60").Value
     ' j = j + 2
        tempBook.Close False
        fileName = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
  ' MsgBox ("ºÑ¹·Ö¡¢éÍÁÙÅŧ Directory àÃÕºÃéÍÂáÅéÇ" & Sheets("Main").Range("e5").Value & " 5555")
  
End Sub

จะทำอย่างไรให้สูตรสามารถคัดลอกข้อมูล ไปใส่ตามห้องแต่ละห้องได้ถูกต้องครับอาจารย์

[aueijung]

ชื่อห้องอยู่ที่ชีท copyrenamefiles Cell H3:H22 ให้ VBA มันทำการเทียบค่า cell กับค่าชีท ถ้าตรงกัน ก็ให้ VBA คัดลอกรายชื่อนักเรียน จึงค่อยคัดลอกไฟล์แล้วเปลี่ยนชื่อไฟล์ วางไฟล์ตาม Directory ตามที่อยู่ของห้อง Cell D3:D22 ในไฟล์ใหม่ที่ถูกสร้างขึ้น ในชีท นักเรียน cell C6:G60 ถ้าไม่ตรงกันก็จบการทำงานครับ

เรียนมาหาข้อกระจ่างและชัดแจ้งในคำสั่งที่กล่าวถึงครับอาจารย์

[snasui]

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

[aueijung]

ชีท copyrenamefiles ที่ cell H3:H22 = ป.1-1 ให้ คัดลอกข้อมูลนักเรียนจากชีท ป.1-1 cell B3:G57 ไปใส่ในไฟล์ชื่อใหม่ที่เปลี่ยนชื่อและคัดลอกไฟล์ใหม่ขึ้นมา ที่ชื่อไฟล์ตรงตาม cell D3:D22 Match กับ cell B3:G57 ให้ตรงกับไฟล์ชื่อ ของแต่ละห้อง
ค่อยข้างจะงงๆ นะครับอาจารย์ พยายามปะติดปะต่อให้มีความหมายที่เข้าใจทีละนิดครับ
ชี้แนะด้วยครับอาจารย์

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 As Integer
Dim tempBook As Workbook, thsBook As Workbook
    
    
    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
        For Each r In rall
            dst = r.Value
            rfl = r.Offset(0, 2).Value
            FileCopy src & "\" & fl, dst & "\" & rfl
            If Err.Number <> 0 Then
                MsgBox "Copy error: " & src & "\" & rfl
            End If
        Next r
        On Error GoTo 0
    End With
    
    Application.ScreenUpdating = False
    
    directory = Sheets("copyrenamefiles").Range("D3").Value
    fileName = Dir(directory & "*.xl??")
    room = Sheets("ป.1-1","ป.1-2","ป.1-3","ป.1-4").Range("B3:G57").Value
    Set thsBook = ThisWorkbook
    j = j + 1
    Do While fileName <> ""
        Set tempBook = Workbooks.Open(directory & fileName)
        thsBook.Sheets("นักเรียน").Cells(3, j) = tempBook.Name
        thsBook.Worksheets("นักเรียน").Cells(3, j).Resize(60, 6).Value = _
            tempBook.Sheets(room).Range("C6:G60").Value
     ' j = j + 2
        tempBook.Close False
        fileName = Dir()
        
    Loop
    
    Application.ScreenUpdating = True
  ' MsgBox ("5555")
  
End Sub

[snasui]

ตัวอย่าง 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 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(1).Range("b6:g60").Value = _
                thsBook.Sheets(r.Offset(0, 4).Value).Range("b3:g57").Value
            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 àÃÕºÃéÍÂáÅéÇ" & Sheets("Main").Range("e5").Value & " 5555")
      
End Sub

[aueijung]

ขอบคุณมากครับอาจารย์ ปรับเป็น คอลัมภ์นิดหน่อย สามารถใช้ได้ดีมากๆ ครับผม
เรียนสอบถามอีกสักเล็กน้อยครับอาจารย์ ข้อมูลวัน/เดือน/ปีเกิด และรหัสประชาชน รูปแบบการแสดงผล ไม่เป็นตามฟอร์แมตข้อมูลจากต้นฉบับ มันแสดงผลเป็น เช่น วดป/เกิด 12/01/2551 ข้อมูลที่แสดงเป็น 38571 และเลขประชาชน แทนที่จะเป็นรหัส 13 หลัก กลายเป็น 12.2221+12 อะไรพวกนี้ เราจะแก้ไขอย่างไรครับ เมื่อไฟล์ต้นฉบับ เป็นฟอร์แมตที่ถูกต้อง แต่ไฟล์ที่สร้างขึ้นมาใหม่ตาม directory แสดงผลคลาดเคลื่อน ดังกล่าว ครับผม

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

[snasui]

สามารถปรับ Format ให้กับข้อมูลปลายทางได้ครับ ตามด้านล่างเป็นตัวอย่างการกำหนดให้เป็น วัน เดือน ปี และกำหนดเป็นตัวเลข 13 หลักตามลำดับ

tempBook.Sheets("นักเรียน").Range("c6:c60").NumberFormat = "dd/mm/yyyy"
tempBook.Sheets("นักเรียน").Range("c6:c60").NumberFormat = "0000000000000"

[aueijung]

ขอบคุณครับอาจารย์ ใช้ได้ดีมากๆ ครับ
ได้แนวความคิดมาต่อยอด วิธีการเขียนโปรแกรมจากอาจารย์ทุกๆ ครั้ง ขอบพระคุณมากๆ ครับอาจารย์