Delete duplicate files that begin with data from A:

S

scotsrule08

New Member
Joined
Jun 21, 2018
Messages
45
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 :eeek:
 
Sort by date Sort by votes
Code: 
[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.
 
Upvote 0

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Thank you for your responce. The macro now throws a run time erro '13' Type mismatch for line

Code: 
Ac****No = Format(cel.Value, "000000000")
 
Upvote 0
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:
Code: 
[B]replace[/B]
AccountNo = Format(cel.Value, "000000000")
[B]with[/B]
AccountNo = cel.Value

The original code assumes that the account number is numeric
 
Last edited:
Upvote 0
There is no longer an error, however excel immediately goes to “not responding” for 30 minutes plus until I cancel it.
 
Upvote 0
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


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
 
Upvote 0
@★ 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 :)
 
Upvote 0
Alright it looks lik the new macro is working. This is what I see in the immediate window when I run the code.


[TABLE="width: 48"]
<colgroup><col width="64" style="width: 48pt; mso-width-source: userset; mso-width-alt: 2340;"> <tbody>[TR]
[TD="width: 64, bgcolor: transparent"]
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]
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
790
Micron
M
S
  • Question Question
Merge two table from different csv files
2 3
Replies
24
Views
591
Soly_90
S
O
  • Question Question
VBA code to merge data from files into one master file
Replies
3
Views
459
jkpieterse
jkpieterse
C
  • Solved
Macro to deduplicate based on A and delete?
2
Replies
12
Views
506
mumps
mumps
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
86
brentcole
B

Forum statistics

Threads
1,223,721
Messages
6,174,091
Members
452,542
Latest member
Bricklin

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top