Snasui Excel Forum

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

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

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

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

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