File System Object, copy rename files.

[arviy2k]

Hi,

I have filenames populated in Column A and what they should be renamed to in Column B. Something like this:

<table width="266" border="0" cellpadding="0" cellspacing="0"><col style="width: 100pt;" width="133" span="2"> <tbody><tr style="height: 15pt;" height="20"> <td class="xl63" style="height: 15pt; width: 100pt;" width="133" height="20"> A</td> <td class="xl63" style="border-left: medium none; width: 100pt;" width="133"> B</td> </tr> <tr style="height: 15pt;" height="20"> <td class="xl64" style="height: 15pt; border-top: medium none;" height="20">18464112_1_31_2010</td> <td class="xl64" style="border-top: medium none; border-left: medium none;" align="right">64112</td> </tr> <tr style="height: 15pt;" height="20"> <td class="xl64" style="height: 15pt; border-top: medium none;" height="20">18476972_1_31_2010</td> <td class="xl64" style="border-top: medium none; border-left: medium none;" align="right">76972</td> </tr> </tbody></table>

So the files are renamed to the last 5 digits of the number, excluding the date.

Filenames listed in column A are all saved in the same folder.

What I need is a macro that will search for the file listed in column A in the folder, rename it as per column B, and save it in a new folder..

steps:
1. locate file listed in column A in the folder(C:\files),
2. Copy the file to the new folder(C:\renamed_files),
3. Rename as per column B

I need the files to be at both locations. It should not delete/move the file. Just copy and rename. Is it possible to do this using excel VBA?

Thanks in advance for your help.

 

[arviy2k]

The files are .pdf..

 

[Ruddles]

This should do the job but sorry, no File System Object. File names should be in columns A and B starting from row 2 without file extensions (as you specified above). Change the bits in red if necessary. The bits in blue are there to flag the cell in column B green/red for success/fail: remove the bits in blue if you don't want this to happen.

[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]Sub CopyFiles()[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]  Const FromFolder As String = "[B][COLOR=red]C:\files\[/COLOR][/B]"
  Const DestFolder As String = "[COLOR=red][B]C:\renamed_files\[/B][/COLOR]"[/SIZE][/FONT]

[FONT=Courier New][SIZE=1]  Dim FromFile As String
  Dim DestFile As String
  
  Dim iLastRow As Long
  Dim iRow As Long
  Dim iFailed As Long
  
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
[COLOR=blue][COLOR=#000000]  [/COLOR][/COLOR][COLOR=blue][B]Columns("B").Interior.Color = xlNone
  
[/B][/COLOR]  For iRow = 2 To iLastRow
    FromFile = FromFolder & Cells(iRow, 1) & ".pdf"
    DestFile = DestFolder & Cells(iRow, 2) & ".pdf"
    On Error Resume Next
    FileCopy FromFile, DestFile
[COLOR=blue][COLOR=black]    If Err.Number <> 0 Then
      iFailed = iFailed + 1
[COLOR=blue][B]      Cells(iRow, 2).Interior.Color = vbRed
[/B][/COLOR][COLOR=blue][B]    Else
      Cells(iRow, 2).Interior.Color = vbGreen
[/B][/COLOR]    End If
[/COLOR][/COLOR]    On Error GoTo 0
  Next iRow
    
  MsgBox vbCrLf _
       & CStr(iLastRow - 1) & " file name" & IIf((iLastRow - 1) = 1, "", "s") & " in list" & Space(12) & vbCrLf & vbCrLf _
       & CStr(iLastRow - 1 - iFailed) & " file" & IIf((iLastRow - 1 - iFailed) = 1, "", "s") & " copied" & Space(12) & vbCrLf & vbCrLf _
       & CStr(iFailed) & " file" & IIf((iFailed) = 1, "", "s") & " failed to copy" & Space(12) & vbCrLf & vbCrLf, _
       vbOKOnly + IIf(iFailed = 0, vbInformation, vbExclamation)[/SIZE][/FONT]
[FONT=Courier New][SIZE=1][/SIZE][/FONT] 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]

 

[arviy2k]

Wow that is amazing.. Works perfectly!! Thank you so much..

 

[pgujju143]

This should do the job but sorry, no File System Object. File names should be in columns A and B starting from row 2 without file extensions (as you specified above). Change the bits in red if necessary. The bits in blue are there to flag the cell in column B green/red for success/fail: remove the bits in blue if you don't want this to happen.

[FONT=Courier New][SIZE=1]Option Explicit[/SIZE][/FONT]
 
[FONT=Courier New][SIZE=1]Sub CopyFiles()[/SIZE][/FONT]
 
[FONT=Courier New][SIZE=1]  Const FromFolder As String = "[B][COLOR=red]C:\files\[/COLOR][/B]"
  Const DestFolder As String = "[COLOR=red][B]C:\renamed_files\[/B][/COLOR]"[/SIZE][/FONT]

[FONT=Courier New][SIZE=1]  Dim FromFile As String
  Dim DestFile As String
  
  Dim iLastRow As Long
  Dim iRow As Long
  Dim iFailed As Long
  
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
[COLOR=blue][B]Columns("B").Interior.Color = xlNone
  
[/B][/COLOR]  For iRow = 2 To iLastRow
    FromFile = FromFolder & Cells(iRow, 1) & ".pdf"
    DestFile = DestFolder & Cells(iRow, 2) & ".pdf"
    On Error Resume Next
    FileCopy FromFile, DestFile
[COLOR=blue][COLOR=black]    If Err.Number <> 0 Then
      iFailed = iFailed + 1
[COLOR=blue][B]      Cells(iRow, 2).Interior.Color = vbRed
[/B][/COLOR][COLOR=blue][B]    Else
      Cells(iRow, 2).Interior.Color = vbGreen
[/B][/COLOR]    End If
[/COLOR][/COLOR]    On Error GoTo 0
  Next iRow
    
  MsgBox vbCrLf _
       & CStr(iLastRow - 1) & " file name" & IIf((iLastRow - 1) = 1, "", "s") & " in list" & Space(12) & vbCrLf & vbCrLf _
       & CStr(iLastRow - 1 - iFailed) & " file" & IIf((iLastRow - 1 - iFailed) = 1, "", "s") & " copied" & Space(12) & vbCrLf & vbCrLf _
       & CStr(iFailed) & " file" & IIf((iFailed) = 1, "", "s") & " failed to copy" & Space(12) & vbCrLf & vbCrLf, _
       vbOKOnly + IIf(iFailed = 0, vbInformation, vbExclamation)[/SIZE][/FONT]
 
[FONT=Courier New][SIZE=1]End Sub[/SIZE][/FONT]

Thanks Bro this is very helpful for me