Append Duplicate file Path: (1)

Joined
Nov 24, 2017
Messages
38
Good Day,

I would like some help on appending a duplicate file name during a looped save.

Name
Name (2)

This is my current code:

Code:
Sub WM_Save_File()

        Dim Path As String
        Dim fileName As String


'Move Original File Name
    Range("d1").Select
    Selection.Cut
    Range("A1").Select
    ActiveSheet.Paste
    
'FIRST CELL
        Dim sht As Worksheet, csheet As Worksheet
        Set csheet = ActiveSheet
        For Each sht In ActiveWorkbook.Worksheets
        If sht.Visible Then
            sht.Activate
            Range("A1").Select
            ActiveWindow.ScrollRow = 1
            ActiveWindow.ScrollColumn = 1
        End If
        Next sht
        csheet.Activate


 If Range("z1") = "TimeStamp" Then


 'SAVE AS


        Path = "C:\Users\CRAGIN\Downloads\Reports w time code\"
        fileName = Range("B1")
        ActiveWorkbook.SaveAs fileName:=Path & fileName & ".xls", FileFormat:=xlNormal
        
        Range("z1").Select
        Selection.ClearContents


 Else


'SAVE AS
'I would like this portion to append when a duplicate file path has been found


        Path = "C:\Users\CRAGIN\Downloads\Reports\"
        fileName = Range("B1")
        ActiveWorkbook.SaveAs fileName:=Path & fileName & ".xls", FileFormat:=xlNormal
        
End If


End Sub
I have tried other codes found online but I keep getting an Invalid procedure call or argument (Error 5) on the below code:

Code:
Sub WM_LoopThroughFiles()'Open and Format all WM reports (Download folder)


   'bEgIn
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic




'Folder where raw data files are stored
    FolderName = "C:\Users\CRAGIN\Downloads\Raw Data Files\"
    If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
    Fname = Dir(FolderName & "*.xls")


'loop through these files
    Do While Len(Fname)


        With Workbooks.Open(FolderName & Fname)
        
'Save original file name in cell d1
    Range("D1").Select
    ActiveCell.FormulaR1C1 = _
    "=LEFT(MID(CELL(""filename""),FIND(""kk"",CELL(""filename"")),LEN(CELL(""filename""))+1-FIND(""kk"",CELL(""filename""))),FIND("".xls"",MID(CELL(""filename""),FIND(""kk"",CELL(""filename"")),LEN(CELL(""filename""))+1-FIND(""kk"",CELL(""filename""))))-1)"
    '=LEFT(MID(CELL("filename"),FIND("kk",CELL("filename")),LEN(CELL("filename"))+1-FIND("kk",CELL("filename"))),FIND(".xls",MID(CELL("filename"),FIND("kk",CELL("filename")),LEN(CELL("filename"))+1-FIND("kk",CELL("filename"))))-1)


    Selection.Copy


    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With


'SAVE Raw data file AS Test
        Dim Path As String
        Dim fileName As String
        Path = "C:\Users\CRAGIN\Downloads\"
        fileName = "Test"
        ActiveWorkbook.SaveAs fileName:=Path & fileName & ".xls", FileFormat:=xlNormal




'applicationRun
Application.Run "WM_Formats"


        End With


        ' go to the next file in the folder
        Fname = Dir 'THIS IS WHERE I GET THE ERROR


    Loop


'Delete Test file
    Kill "C:\Users\CRAGIN\Downloads\Test.xls"


'Application.Run "WM_LoopThroughFiles_FileName"


    'eNd
Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub
Thank you
Crystal
 

Some videos you may like

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
How about substituting this code for your Else code:

Code:
    Path = "C:\Users\CRAGIN\Downloads\Reports\"
    fileName = Range("B1")
    If fileExists(Path, fileName & ".xls") Then
        Dim i As Integer
        i = 1
        Do
            i = i + 1
        Loop While fileExists(Path, fileName & " (" & i & ").xls")
        fileName = fileName & " (" & i & ")"
    End If
    ActiveWorkbook.SaveAs fileName:=Path & fileName & ".xls", FileFormat:=xlNormal
Add this function as well:
Code:
Function fileExists(sFolderName As String, sFileName As String) As Boolean
    Dim objFso As Object

    Set objFso = CreateObject("Scripting.FileSystemObject")
    If Right(sFolderName, 1) <> Application.PathSeparator Then sFolderName = sFolderName & Application.PathSeparator
    fileExists = objFso.fileExists(sFolderName & "\" & sFileName)
End Function
 
Joined
Nov 24, 2017
Messages
38
Good Morning,

I have another quick question if you have a moment. I want to incorporate this fix into a move files macro but I'm having trouble getting it to work.

If the file exists can it append it (the current fix), or even overwrite it?

Current Code:
Code:
Sub MoveFiles()Dim MyFile As String
MyFile = Dir("C:\Users\Cragin\Downloads\0. Raw Data Files\")
Do Until MyFile = ""


Name "C:\Users\Cragin\Downloads\0. Raw Data Files\" & MyFile As "C:\Users\Cragin\Downloads\old\" & MyFile


MyFile = Dir
Loop
End Sub
 

shknbk2

Board Regular
Joined
Mar 5, 2016
Messages
240
How about something like this:
Code:
Sub MoveFiles()
    Dim MyFile As String, overwrite As Boolean
    Dim oldFolder As String, newFolder As String
    Dim newFile As String
    
    'If overwrite is True, the file in the destination is deleted prior to moving the source file
    'If overwrite is False, the source file is copied as (2), (3), etc.
    overwrite = False
    
    oldFolder = "C:\Users\Cragin\Downloads\0. Raw Data Files\"
    newFolder = "C:\Users\Cragin\Downloads\old\"
    MyFile = Dir(oldFolder)
    Do Until MyFile = ""
        newFile = MyFile
        If fileExists(newFolder, newFile) Then
            Select Case overwrite
                Case True
                    Kill newFolder & newFile
                Case False
                    newFile = nextName(newFolder, MyFile)
            End Select
        End If
        Name oldFolder & MyFile As newFolder & newFile
        MyFile = Dir
    Loop
End Sub

Function fileExists(sFolderName As String, sFileName As String) As Boolean
    Dim objFso As Object

    Set objFso = CreateObject("Scripting.FileSystemObject")
    If Right(sFolderName, 1) <> Application.PathSeparator Then sFolderName = sFolderName & Application.PathSeparator
    fileExists = objFso.fileExists(sFolderName & "\" & sFileName)
End Function

Function nextName(sFolderName As String, ByVal sFileName As String) As String
    Dim i As Integer, fileExt As String
    
    If Right(sFolderName, 1) <> Application.PathSeparator Then sFolderName = sFolderName & Application.PathSeparator
    fileExt = Mid(sFileName, InStrRev(sFileName, "."))
    sFileName = Left(sFileName, Len(sFileName) - Len(fileExt))
    i = 1
    Do
        i = i + 1
    Loop While fileExists(sFolderName, sFileName & " (" & i & ")" & fileExt)
    nextName = sFileName & " (" & i & ")" & fileExt
End Function
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,100,139
Messages
5,472,747
Members
406,835
Latest member
steve43040

This Week's Hot Topics

Top