Save multiple files in the same folder as copies with Same Name with Word "Copy" ?

[MrSpark]

I have been using below code which create the copy of same workbook in the same folder with same name "Copy".

What i want is I need that code in a way, Where i will run the code it will ask me to select a folder after selecting the folder which have multiple workbooks and also on their sub folder. It should run and create copies. that way my huge time will saved.

Any help will be much appreciated.

Dim DISTNAME As String

DISTNAME = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & "Copy" & ".xlsx"
DISTNAME = ActiveWorkbook.Path & Application.PathSeparator & DISTNAME

Sheets.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
ActiveWorkbook.SaveAs DISTNAME

 

[Tetra201]

See if the following works for you (please test it on a non-critical folder first):

Sub CopyAll()
    Dim f As FileDialog, s As String
    Set f = Application.FileDialog(msoFileDialogFolderPicker)
    With f
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Set f = Nothing: Exit Sub
        s = .SelectedItems(1)
    End With
    Set f = Nothing
    s = """for /R " & s & " %A in (*.xl*) do copy ""%A"" ""%~dpnA - Copy%~xA"""""
    Shell "cmd /c " & s
End Sub

 

[MrSpark]

I have this folder with 5 files and run the code but nothing happens.

 

[Marc L]

Hi, a VBA demonstration as a beginner starter :​

Sub Demo1()
      Const E = ".xlsx"
        Dim P$, F$
    With Application.FileDialog(4)
        If .Show Then P = .SelectedItems(1) & "\" Else Exit Sub
    End With
          F = Dir$(P & "*" & E)
    While F > ""
          FileCopy P & F, P & Replace(F, E, " Copy " & E)
          F = Dir$
    Wend
End Sub

 

[Tetra201]

I have this folder with 5 files and run the code but nothing happens.

Oops, I have missed a couple of double quotes. Please try the corrected version:

Sub CopyAll()
    Dim f As FileDialog, s As String
    Set f = Application.FileDialog(msoFileDialogFolderPicker)
    With f
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Set f = Nothing: Exit Sub
        s = .SelectedItems(1)
    End With
    Set f = Nothing
    s = """for /R """ & s & """ %A in (*.xl*) do copy ""%A"" ""%~dpnA - Copy%~xA"""""
    Shell "cmd /c " & s
End Sub

 

[MrSpark]

Thank you very much Sir one more last favor. If i want to delete those workbooks which copies have been generated with above code. then how to achieve this.

 

[Tetra201]

You are welcome.

Here is a copy removal tool -- please test it on a non-critical folder first:

Sub DelCopy()
    Dim f As FileDialog, s As String
    Set f = Application.FileDialog(msoFileDialogFolderPicker)
    With f
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then Set f = Nothing: Exit Sub
        s = .SelectedItems(1)
    End With
    Set f = Nothing
    s = """for /R """ & s & """ %A in (*.xl*) do del ""%~dpnA - Copy%~xA"""""
    Shell "cmd /c " & s
End Sub