Append Duplicate file Path: (1)

[crystalneedshelpplzthnx]

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:

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:

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

 

[shknbk2]

How about substituting this code for your Else 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:

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

 

[crystalneedshelpplzthnx]

Worked like a charm! Thnx so much!

 

[crystalneedshelpplzthnx]

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:

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]

How about something like this:

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

 

[crystalneedshelpplzthnx]

Oh wow, you gave me both! I can't wait to try them out! Thank you!!!!!

 

[crystalneedshelpplzthnx]

Yup, that did it! Thank you for sharing your magic with me!

Crystal