VBA to duplicate a file in folder by n times

[chasoe]

Hi,

I just come across a problem on how use VBA can simulate in window explorer, to copy and paste a specific file in same folder as many times as the user may require.

Without the codes, I've to click this specific file (say abc.xlsx) in window explorer, and press Ctrl + C, and then press Ctrl + V 45 times in order to make 45 copies of the original abc.xlsx,
ie
abc.xlsx
abc - copy.xlsx
abc - copy (2).xlsx
abc - copy (3).xlsx
.......
abc - copy (44).xlsx

The reason to make so many copies is that I'll have another set of codes (searched from internet) to list out the folder files and rename them one by one before despatching them to 45 recipients by emails for their further update of the content in the file.

As I find it too clumsy, I think there should be codes that can directly ask user how many copies of the existing file in the folder to make and then proceed accordingly.

See if anyone could kindly help.

Many thanks

 

[Saurabhj]

Hi,

Please check below code:

Sub copyFiles()
Dim folderPath As String
Dim copyReqd As Integer, copyCount As Integer

folderPath = "C:\folderpath\"

If Dir(folderPath) = vbNullString Then
    MsgBox "No file available"
    Exit Sub
End If

copyReqd = CInt(InputBox("How many copy required of " & Dir(folderPath), "Enter Duplicate count"))

For copyCount = 1 To copyReqd
    FileCopy folderPath & Dir(folderPath), folderPath & "copy" & copyCount & ".xlsx"
Next

MsgBox copyReqd & " copies created successfully."

End Sub

 

[johnnyL]

@chasoe how about:

Sub DuplicateFile()
'
    Dim DuplicateNumber     As Long, NumberOfDuplicates As Long
    Dim FileNameOnly        As String, FilePath         As String, FileToCopy   As String
'
    FileToCopy = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Please select the file that you want to make copies of!")
'
    If FileToCopy = "False" Then
        Exit Sub
    Else
        Workbooks.Open Filename:=FileToCopy
    End If
'
    FilePath = Left(FileToCopy, InStrRev(FileToCopy, "\"))
    FileNameOnly = Mid(ActiveWorkbook.Name, 1, InStr(1, ActiveWorkbook.Name, ".") - 1)
'
    NumberOfDuplicates = InputBox("How many copies of the active workbook do you want to make?")
'
    If NumberOfDuplicates >= 1 Then
        For DuplicateNumber = 1 To NumberOfDuplicates
            If DuplicateNumber = 1 Then
                ActiveWorkbook.SaveCopyAs FilePath & FileNameOnly & " - copy" & ".xlsx"
            Else
                ActiveWorkbook.SaveCopyAs FilePath & FileNameOnly & " - copy(" & DuplicateNumber & ")" & ".xlsx"
            End If
        Next
   End If
'
    ActiveWorkbook.Close savechanges:=False
End Sub

 

[chasoe]

@Saurabhj Thank you
@johnnyL Thank you

Both set of codes have been tested OK, I'll see which one best suit my situation and modify a bit, and incorporate into my other codes to make them complete.

Many thanks indeed.

 

[johnnyL]

Glad we could help @chasoe.

 

[d1pakjha]

@chasoe how about:

Sub DuplicateFile()
'
    Dim DuplicateNumber     As Long, NumberOfDuplicates As Long
    Dim FileNameOnly        As String, FilePath         As String, FileToCopy   As String
'
    FileToCopy = Application.GetOpenFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Please select the file that you want to make copies of!")
'
    If FileToCopy = "False" Then
        Exit Sub
    Else
        Workbooks.Open Filename:=FileToCopy
    End If
'
    FilePath = Left(FileToCopy, InStrRev(FileToCopy, "\"))
    FileNameOnly = Mid(ActiveWorkbook.Name, 1, InStr(1, ActiveWorkbook.Name, ".") - 1)
'
    NumberOfDuplicates = InputBox("How many copies of the active workbook do you want to make?")
'
    If NumberOfDuplicates >= 1 Then
        For DuplicateNumber = 1 To NumberOfDuplicates
            If DuplicateNumber = 1 Then
                ActiveWorkbook.SaveCopyAs FilePath & FileNameOnly & " - copy" & ".xlsx"
            Else
                ActiveWorkbook.SaveCopyAs FilePath & FileNameOnly & " - copy(" & DuplicateNumber & ")" & ".xlsx"
            End If
        Next
   End If
'
    ActiveWorkbook.Close savechanges:=False
End Sub

HI, is it possible to do this for all type of files instead of just excel workbook?