Delete duplicate files that begin with data from A:

[scotsrule08]

Good day,

I am trying to run a macro that will autmatically delete one copy of a duplicate file based on the first 9 characters of the file.
These 9 characters are found in row A:

So I would need to select what folder this Macro would run in, and then list in column A: the first 9 characters of the file name, then it would delete any extra duolicates and keep only one copy.

I have been playing with this and am struggling.


TIA

 

[Yongle]

Looks like the code is working
Let's test step-by-step
I suggest you again paste all the code into your workbook and simply amend the 2 folders

STEP 1 - try this
- 3 X Debug.Print lines removed
- Exit Do test increased to 6

When you run the code, is the result what you expect (see immendiate window)

Option Explicit
Const OrigFldr = [COLOR=#000080]"C:\Test\AccountFiles\[/COLOR]"                'end with "\"
Const DupFldr = "[COLOR=#000080]C:\Test\AccountFiles\Duplicates[/COLOR]\"      'end with "\"

Sub MainSub()            

    Dim AccountNo As String, accRng As Range, cel As Range
    Set accRng = Range("A2", Range("A" & Rows.count).End(xlUp))
    For Each cel In accRng
        AccountNo = Format(cel.Value, "000000000")
        MoveFiles (AccountNo)
    Next cel
End Sub

Private Sub MoveFiles(AccountNo As String)

Dim LatestFile As String, strFile As String, fdate, oDate, oFS As Object
Dim testcount As Integer
Set oFS = CreateObject("Scripting.FileSystemObject")

'determine latest file
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
        fdate = oFS.GetFile(OrigFldr & strFile).DateCreated
        
        If fdate > oDate Then
            oDate = fdate
            LatestFile = strFile
        End If
        strFile = Dir
        testcount = testcount + 1: If testcount = [COLOR=#ff0000]6[/COLOR] Then Exit Do
    Loop
        testcount = 0
'move earlier fies
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
       If strFile <> LatestFile Then Debug.Print "move " & OrigFldr & strFile & " to " & DupFldr & strFile
        strFile = Dir
        testcount = testcount + 1: If testcount = [COLOR=#ff0000]6[/COLOR] Then Exit Do
    Loop

'tidy up
    Set oFS = Nothing
    oDate = ""
    fdate = ""

End Sub

 

[Yongle]

ONLY if Step 1 works

STEP 2
- the test to Exit Do has now been removed
- does the code now run without endless loop?

Option Explicit
Const OrigFldr = "[COLOR=#000080]C:\Test\AccountFiles[/COLOR]\"                'end with "\"
Const DupFldr = "[COLOR=#000080]C:\Test\AccountFiles\Duplicates\[/COLOR]"      'end with "\"

Sub MainSub()            

    Dim AccountNo As String, accRng As Range, cel As Range
    Set accRng = Range("A2", Range("A" & Rows.count).End(xlUp))
    For Each cel In accRng
        AccountNo = Format(cel.Value, "000000000")
        MoveFiles (AccountNo)
    Next cel
End Sub

Private Sub MoveFiles(AccountNo As String)

Dim LatestFile As String, strFile As String, fdate, oDate, oFS As Object
Set oFS = CreateObject("Scripting.FileSystemObject")

'determine latest file
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
        fdate = oFS.GetFile(OrigFldr & strFile).DateCreated
        
        If fdate > oDate Then
            oDate = fdate
            LatestFile = strFile
        End If
        strFile = Dir
    Loop
        testcount = 0
'move earlier fies
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
       If strFile <> LatestFile Then Debug.Print "move " & OrigFldr & strFile & " to " & DupFldr & strFile
        strFile = Dir
    Loop

'tidy up
    Set oFS = Nothing
    oDate = ""
    fdate = ""

End Sub

 

[scotsrule08]

I am still getting an error at "AccountNo = Format(cel.Value,"000000000")

WE ARE SOOOOOOO CLOSE!!!!!

Sub MainSub()

    Dim AccountNo As String, accRng As Range, cel As Range
    Set accRng = Range("A2", Range("A" & Rows.Count).End(xlUp))
    For Each cel In accRng
        AccountNo = Format(cel.Value, "000000000")
        MoveFiles (AccountNo)
    Next cel
End Sub

ONLY if Step 1 works

STEP 2
- the test to Exit Do has now been removed
- does the code now run without endless loop?

Option Explicit
Const OrigFldr = "[COLOR=#000080]C:\Test\AccountFiles[/COLOR]\"                'end with "\"
Const DupFldr = "[COLOR=#000080]C:\Test\AccountFiles\Duplicates\[/COLOR]"      'end with "\"

Sub MainSub()            

    Dim AccountNo As String, accRng As Range, cel As Range
    Set accRng = Range("A2", Range("A" & Rows.count).End(xlUp))
    For Each cel In accRng
        AccountNo = Format(cel.Value, "000000000")
        MoveFiles (AccountNo)
    Next cel
End Sub

Private Sub MoveFiles(AccountNo As String)

Dim LatestFile As String, strFile As String, fdate, oDate, oFS As Object
Set oFS = CreateObject("Scripting.FileSystemObject")

'determine latest file
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
        fdate = oFS.GetFile(OrigFldr & strFile).DateCreated
        
        If fdate > oDate Then
            oDate = fdate
            LatestFile = strFile
        End If
        strFile = Dir
    Loop
        testcount = 0
'move earlier fies
    strFile = Dir(OrigFldr & AccountNo & "*.xlsx")
    Do While strFile <> ""
       If strFile <> LatestFile Then Debug.Print "move " & OrigFldr & strFile & " to " & DupFldr & strFile
        strFile = Dir
    Loop

'tidy up
    Set oFS = Nothing
    oDate = ""
    fdate = ""

End Sub

 

[Yongle]

Try using this instead (amend for both posts #21 and #22 )

AccountNo = cel.Value