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]

[I][B]Amend this line[/B][/I]
fdate = oFS.GetFile(strFile).DateCreated
[I][B]to[/B][/I]
fdate = oFS.GetFile([COLOR=#ff0000]OrigFldr & strFile[/COLOR]).DateCreated

Let me know if that solves it.

 

[scotsrule08]

Thank you for your responce. The macro now throws a run time erro '13' Type mismatch for line

Ac****No = Format(cel.Value, "000000000")

 

[Yongle]

Does the account number always contain exactly 9 numerical characters?
- I suspect that it must be alpha-numeric from that error


If the account number is alpha-numeric:

[B]replace[/B]
AccountNo = Format(cel.Value, "000000000")
[B]with[/B]
AccountNo = cel.Value

The original code assumes that the account number is numeric

 

[scotsrule08]

There is no longer an error, however excel immediately goes to “not responding” for 30 minutes plus until I cancel it.

 

[Yongle]

which version of Excel are you using?

 

[scotsrule08]

Excel 2013

 

[A_G_3]

Hello - i am having the EXACT issue as Scotsrule08 where excel does not respond.
thanks

 

[Yongle]

I would expect the code to work with Excel 2013
Please replace the original code with the one below, amend the 2 folder name, ensure the correct sheet is active and run it from the VBA window
(do not simply amend previous code- start again so that we are 100% in the same place!!)
I have added 3 lines to print to immediate window, and TestCount to enable the loop to be exited after 1 duplicate is found

Please post what you see in the immediiate window - that should tell me where the code is failing for you
I know that you cannot do that but you can paste it into notepad and "doctor" it so that I can see what is going on
thanks

This is what I see in the immediate window
XX AA1234567 1.xlsx
YY AA1234567 1.xlsx 24/06/2018 09:57:06
YY AA1234567 2.xlsx 24/06/2018 09:57:28 24/06/2018 09:57:06
ZZ AA1234567 1.xlsx
move C:\Test\AccountFiles\AA1234567 1.xlsx to C:\Test\AccountFiles\Duplicates\AA1234567 1.xlsx
ZZ AA1234567 2.xlsx
XX AB1234567 1.xlsx
YY AB1234567 1.xlsx 24/06/2018 09:58:27
YY AB1234567 2.xlsx 24/06/2018 09:58:38 24/06/2018 09:58:27
ZZ AB1234567 1.xlsx
move C:\Test\AccountFiles\AB1234567 1.xlsx to C:\Test\AccountFiles\Duplicates\AB1234567 1.xlsx
ZZ AB1234567 2.xlsx

Option Explicit
Const OrigFldr = "C:\Test\AccountFiles\"                'end with "\"
Const DupFldr = "C:\Test\AccountFiles\Duplicates\"      '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
[COLOR=#ff0000]Dim testcount As Integer[/COLOR]
Set oFS = CreateObject("Scripting.FileSystemObject")

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

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

End Sub

 

[Yongle]

@★ A_G_3
Thanks for letting me know that you have the same issue.
I will deal with OP rather than you to resolve this issue otherwise the thread will get very messy
Happy to help you separately afterwards

 

[scotsrule08]

Alright it looks lik the new macro is working. This is what I see in the immediate window when I run the code.

[FONT=Times New Roman][/FONT][TABLE="width: 6"] [FONT=Times New Roman] [/FONT]<tbody>[TR] [FONT=Times New Roman] [/FONT][TD="width: 624, bgcolor: transparent"][FONT=Times New Roman] [/FONT][COLOR=black][FONT=Calibri]YY 333334444 06-15-18.xlsx 6/27/201812:00:00AM 6/27/2018 12:00:00AM[/FONT][/COLOR] [FONT=Times New Roman] [/FONT][/TD] [FONT=Times New Roman] [/FONT][/TR] [FONT=Times New Roman] [/FONT][TR] [FONT=Times New Roman] [/FONT][TD="width: 624, bgcolor: transparent"][FONT=Times New Roman] [/FONT][COLOR=black][FONT=Calibri]ZZ 333334444 06-14-18.xlsx[/FONT][/COLOR] [FONT=Times New Roman] [/FONT][/TD] [FONT=Times New Roman] [/FONT][/TR] [FONT=Times New Roman] [/FONT][TR] [FONT=Times New Roman] [/FONT][TD="width: 624, bgcolor: transparent"][FONT=Times New Roman] [/FONT][COLOR=black][FONT=Calibri]ZZ 333334444 06-15-18.xlsx[/FONT][/COLOR] [FONT=Times New Roman] [/FONT][/TD] [FONT=Times New Roman] [/FONT][/TR] [FONT=Times New Roman] [/FONT][TR] [FONT=Times New Roman] [/FONT][TD="width: 624, bgcolor: transparent"][FONT=Times New Roman] [/FONT][COLOR=black][FONT=Calibri]move C:\Users\ME \Desktop\TESTFOLDER\333334444 06-15-18.xlsx to C:\Users\ME\Desktop\DUPLICATE\333334444 06-15-18.xlsx[/FONT][/COLOR] [FONT=Times New Roman] [/FONT][/TD] [FONT=Times New Roman] [/FONT][/TR] [FONT=Times New Roman][/FONT]</tbody>[/TABLE] [FONT=Times New Roman][/CO[/FONT]DE][/COLOR][/SIZE][/FONT] [/TD] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][/TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TD="bgcolor: transparent"][/TD] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][/TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TD="bgcolor: transparent"][/TD] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][/TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][TD="bgcolor: transparent"][/TD] [FONT=Times New Roman][SIZE=3][COLOR=#000000] [/COLOR][/SIZE][/FONT][/TR] [FONT=Times New Roman][SIZE=3][COLOR=#000000][/COLOR][/SIZE][/FONT]</tbody>[/TABLE] [QUOTE="Yongle, post: 5094925, member: 319522"]I would expect the code to work with Excel 2013 Please replace the original code with the one below, amend the 2 folder name, ensure the correct sheet is active and run it from the VBA window (do not simply amend previous code- start again so that we are 100% in the same place!!) I have added 3 lines to print to immediate window, and TestCount to enable the loop to be exited after 1 duplicate is found Please post what you see in the immediiate window - that should tell me where the code is failing for you I know that you cannot do that ;) but you can paste it into notepad and "doctor" it so that I can see what is going on thanks [B]This is what I see in the immediate window[/B] XX AA1234567 1.xlsx YY AA1234567 1.xlsx 24/06/2018 09:57:06 YY AA1234567 2.xlsx 24/06/2018 09:57:28 24/06/2018 09:57:06 ZZ AA1234567 1.xlsx move [COLOR=#000080]C:\Test\AccountFiles\AA1234567 1.xlsx[/COLOR] to [COLOR=#000080]C:\Test\AccountFiles\Duplicates\AA1234567 1.xlsx[/COLOR] ZZ AA1234567 2.xlsx XX AB1234567 1.xlsx YY AB1234567 1.xlsx 24/06/2018 09:58:27 YY AB1234567 2.xlsx 24/06/2018 09:58:38 24/06/2018 09:58:27 ZZ AB1234567 1.xlsx move [COLOR=#000080]C:\Test\AccountFiles\AB1234567 1.xlsx [/COLOR]to [COLOR=#000080]C:\Test\AccountFiles\Duplicates\AB1234567 1.xlsx[/COLOR] ZZ AB1234567 2.xlsx [CODE]Option Explicit Const OrigFldr = "C:\Test\AccountFiles\" 'end with "\" Const DupFldr = "C:\Test\AccountFiles\Duplicates\" '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 [COLOR=#ff0000]Dim testcount As Integer[/COLOR] Set oFS = CreateObject("Scripting.FileSystemObject") 'determine latest file strFile = Dir(OrigFldr & AccountNo & "*.xlsx") [COLOR=#ff0000]Debug.Print "XX " & strFile[/COLOR] Do While strFile <> "" fdate = oFS.GetFile(OrigFldr & strFile).DateCreated [COLOR=#ff0000]Debug.Print "YY " & strFile & " " & fdate & " " & oDate[/COLOR] If fdate > oDate Then oDate = fdate LatestFile = strFile End If strFile = Dir [COLOR=#ff0000]testcount = testcount + 1: If testcount = 2 Then Exit Do[/COLOR] Loop [COLOR=#ff0000]testcount = 0[/COLOR] 'move earlier fies strFile = Dir(OrigFldr & AccountNo & "*.xlsx") Do While strFile <> "" [COLOR=#ff0000]Debug.Print "ZZ " & strFile[/COLOR] If strFile <> LatestFile Then Debug.Print "move " & OrigFldr & strFile & " to " & DupFldr & strFile strFile = Dir [COLOR=#ff0000]testcount = testcount + 1: If testcount = 2 Then Exit Do[/COLOR] Loop 'tidy up Set oFS = Nothing oDate = "" fdate = "" End Sub [/QUOTE]

<colgroup><col width="64" style="width: 48pt; mso-width-source: userset; mso-width-alt: 2340;"> <tbody>