Excel Forum

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: 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

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