Macro to Copy, Pasete and Rename

[comroids]

Hi All,
I need a macro to copy a file in a folder and make multiple copies of it in that very folder.


Step 1 : Select the file you want to make copies of.
Step 2 : Select the destination folder / auto select it based on the folder of the file in Step 1.
Step 3 : List all the filenames in Column A starting from Cell A2 (Header Cell : FILENAMES)
Step 3 : Run Macro that will pick up the filenames listed in a column starting from Cell A2
and create multiple copies of that file with the names in Column A.

This macro should loop till the end of list in Column A is reached.

** The files can be of any type.

 

[CharlesChuckieCharles]

This should do it

Sub ReplicateFile()

Dim SourceFileApp As Application
Dim TargetFolderApp As Application
Dim vitemselecetd As Variant

Set SourceFileApp = Application
Set TargetFolderApp = Application

MyFolder = ""

listdepth = Cells(Rows.Count, 1).End(xlUp).Row
With SourceFileApp.FileDialog(msoFileDialogFilePicker)  ' get file to replicate
    .AllowMultiSelect = False
    If .Show = -1 Then
        
        For Each vitemselecetd In .SelectedItems
           
         If MyFolder = "" Then
            With TargetFolderApp.FileDialog(msoFileDialogFolderPicker)  ' get target directory
                    If .Show = -1 Then
                       If .SelectedItems.Count > 1 Then
                         MsgBox "One target folder only please"
                         Exit Sub
                       ElseIf .SelectedItems.Count = 1 Then
                          MyFolder = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\")
                       End If
                    Else
                       MsgBox "No target folder Chosen"
                       Exit Sub
                    End If
            End With
          End If
    
       'copy file to eveyname in list
        For x = 1 To listdepth
          FileCopy vitemselecetd, MyFolder & IIf(InStr(1, ".", Cells(x, 1)) > 0, Cells(x, 1), Cells(x, 1) & Right(vitemselecetd, Len(vitemselecetd) - InStrRev(vitemselecetd, ".", Len(vitemselecetd)) + 1))
        Next x
    Next vitemselecetd
 
    
    
    Else
                    MsgBox "No Source File Chosen"
                    Exit Sub
 
    End If
End With

End Sub

Note that it doesn't deal with creating a file name thats already there

should it overwrite? or error? or try to increment the name string until its unique?

 

[comroids]

This should do it

Sub ReplicateFile()

Dim SourceFileApp As Application
Dim TargetFolderApp As Application
Dim vitemselecetd As Variant

Set SourceFileApp = Application
Set TargetFolderApp = Application

MyFolder = ""

listdepth = Cells(Rows.Count, 1).End(xlUp).Row
With SourceFileApp.FileDialog(msoFileDialogFilePicker)  ' get file to replicate
    .AllowMultiSelect = False
    If .Show = -1 Then
        
        For Each vitemselecetd In .SelectedItems
           
         If MyFolder = "" Then
            With TargetFolderApp.FileDialog(msoFileDialogFolderPicker)  ' get target directory
                    If .Show = -1 Then
                       If .SelectedItems.Count > 1 Then
                         MsgBox "One target folder only please"
                         Exit Sub
                       ElseIf .SelectedItems.Count = 1 Then
                          MyFolder = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = "\", "", "\")
                       End If
                    Else
                       MsgBox "No target folder Chosen"
                       Exit Sub
                    End If
            End With
          End If
    
       'copy file to eveyname in list
        For x = 1 To listdepth
          FileCopy vitemselecetd, MyFolder & IIf(InStr(1, ".", Cells(x, 1)) > 0, Cells(x, 1), Cells(x, 1) & Right(vitemselecetd, Len(vitemselecetd) - InStrRev(vitemselecetd, ".", Len(vitemselecetd)) + 1))
        Next x
    Next vitemselecetd
 
    
    
    Else
                    MsgBox "No Source File Chosen"
                    Exit Sub
 
    End If
End With

End Sub

Note that it doesn't deal with creating a file name thats already there

should it overwrite? or error? or try to increment the name string until its unique?

Hi...thanks a ton
works like a charm...you are a life saver.