Help VBA find the Duplicate files and remove to Folder "OLD"

[excel_newbie86]

Hi all, I'm new in this forum.

I have alot files in Folder, file name the same structure like: aaaaaa-bbbbbbbb-cccccccc-dddddd-ee-f-gg => file name have 39 character with extension (.xlsx, .xls, .prt)
Now I want to have macro VBA to check if file name duplicate 32 character in the left (like: aaaaaa-bbbbbbbb-cccccccc-dddddd-)
If duplicate file found, keep file with the largest number "gg", all files duplicate smaller will be remove to Folder (OLD)

I Attachment 02 picturer with Pictute(1) is the Original file in my Folder and Picturer(2) is file I want to do.
For examble:
Keep file A00014-99207001-01207004-202006-SI-M-09 and remove all file like A00014-99207001-01207004-202006- to Folder (OLD) because 09 is the largest number

Next file
Keep file G00854-99314001-79314013-202006-BI-M-06 and remove all file like G00854-99314001-79314013-202006- to Folder (OLD) because 06 is the largest number

 

[excel_newbie86]

Some one can help me or give some idea to do this.

thanks.

 

[John_w]

Welcome to MrExcel forums.

Edit the code where indicated and run this macro on a copy of your folder, which should also contain the OLD subfolder.

Public Sub Move_Duplicate_Files()

    Dim fromFolder As String, toFolder As String
    Dim file As String
    Dim files() As String, n As Long, i As Long
    
    fromFolder = "C:\path\to\Copy of folder\"       'CHANGE THIS
    toFolder = "C:\path\to\Copy of folder\OLD"      'CHANGE THIS
    
    If Right(fromFolder, 1) <> "\" Then fromFolder = fromFolder & "\"
    If Right(toFolder, 1) <> "\" Then toFolder = toFolder & "\"
    
    n = 0
    file = Dir(fromFolder & "*.*")
    While file <> vbNullString
        If file Like "??????-????????-????????-??????-??-?-??.*" Then
            ReDim Preserve files(n)
            files(n) = file
            n = n + 1
        End If
        file = Dir
    Wend

    If n > 0 Then

        BubbleSort files
        
        'Add empty slot at end to facilitate loop end boundary
        
        ReDim Preserve files(n)
        
        'Move duplicate files
        
        n = 0
        While n < UBound(files)
            Debug.Print "Keep " & files(n)
            i = n
            n = n + 1
            While n < UBound(files) And Left(files(n), 32) = Left(files(i), 32)
                Debug.Print "Move " & files(n)
                Name fromFolder & files(n) As toFolder & files(n)
                n = n + 1
            Wend
        Wend
        
    End If
    
End Sub


Private Sub BubbleSort(data() As String)

    'Sort a one-dimensional string array in descending order
    
    Dim i As Long, j As Long
    Dim temp As String
    
    For i = LBound(data) To UBound(data) - 1
        For j = i + 1 To UBound(data)
            If data(i) < data(j) Then
                temp = data(i)
                data(i) = data(j)
                data(j) = temp
            End If
        Next
    Next
     
End Sub

 

[excel_newbie86]

Great code @John_w

fromFolder = "C:\path\to\Copy of folder\"

Could you change code to brown to choose folder? I have diffrience folder to do this so I have to change this line each time to work.

Many thanks.

 

[John_w]

We can use Application.FileDialog(msoFileDialogFolderPicker) to browse and choose a folder.

Here is the complete code:

Option Explicit

Public Sub Move_Duplicate_Files()

    Dim fromFolder As String, toFolder As String
    Dim file As String
    Dim files() As String, n As Long, i As Long
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing duplicate files"
        .InitialFileName = ThisWorkbook.Path
        If Not .Show Then Exit Sub
        fromFolder = .SelectedItems(1) & "\"
        toFolder = fromFolder & "OLD\"
    End With
       
    n = 0
    file = Dir(fromFolder & "*.*")
    While file <> vbNullString
        If file Like "??????-????????-????????-??????-??-?-??.*" Then
            ReDim Preserve files(n)
            files(n) = file
            n = n + 1
        End If
        file = Dir
    Wend

    If n > 0 Then

        BubbleSort files
       
        'Add empty slot at end to facilitate loop end boundary
       
        ReDim Preserve files(n)
       
        'Move duplicate files
       
        n = 0
        While n < UBound(files)
            Debug.Print "Keep " & files(n)
            i = n
            n = n + 1
            While n < UBound(files) And Left(files(n), 32) = Left(files(i), 32)
                Debug.Print "Move " & files(n)
                Name fromFolder & files(n) As toFolder & files(n)
                n = n + 1
            Wend
        Wend
       
    End If
   
End Sub


Private Sub BubbleSort(data() As String)

    'Sort a one-dimensional string array in descending order
   
    Dim i As Long, j As Long
    Dim temp As String
   
    For i = LBound(data) To UBound(data) - 1
        For j = i + 1 To UBound(data)
            If data(i) < data(j) Then
                temp = data(i)
                data(i) = data(j)
                data(j) = temp
            End If
        Next
    Next
    
End Sub

 

[excel_newbie86]

Dear @John_w , this's perfect code.

May I have the last question is how to count files was removed. Could you help me have message box like: Removed x files

Thanks./.

 

[John_w]

Why not have a go yourself? It's a very simple change. You need to declare (Dim) a suitable variable, initialise in the correct place, increment it in the correct place and display the message (MsgBox function). I let you decide these things, but come back if you need help.

 

[excel_newbie86]

Why not have a go yourself? It's a very simple change. You need to declare (Dim) a suitable variable, initialise in the correct place, increment it in the correct place and display the message (MsgBox function). I let you decide these things, but come back if you need help.

I add this line before the "end sub" but only message box appear, there's no file number count

n = 0
        While n < UBound(files)
            Debug.Print "Keep " & files(n)
            i = n
            n = n + 1
            While n < UBound(files) And Left(files(n), 32) = Left(files(i), 32)
                Debug.Print "Move " & files(n)
                Name fromFolder & files(n) As toFolder & files(n)
                n = n + 1
            Wend
        Wend
    End If
MsgBox "Files remove: " & files(n)
End Sub

 

[John_w]

files(n) isn't the number of files moved. files() is an array containing all the matching file names from the initial Dir loop, with files(0), files(1), files(2) etc. the individual file names. And at the end of the 'move files' loop files(n) is actually the empty array slot, hence why nothing follows your MsgBox text.

Try this. The MsgBox for the number of files moved displays "files " or "file" depending on the number of files moved (zero, one or more) and I've added another MsgBox if no matching files are found in the selected folder.

Public Sub Move_Duplicate_Files()

    Dim fromFolder As String, toFolder As String
    Dim file As String
    Dim files() As String, n As Long, i As Long
    Dim numMoved As Long
   
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing duplicate files"
        .InitialFileName = ThisWorkbook.Path
        If Not .Show Then Exit Sub
        fromFolder = .SelectedItems(1) & "\"
        toFolder = fromFolder & "OLD\"
    End With
       
    n = 0
    file = Dir(fromFolder & "*.*")
    While file <> vbNullString
        If file Like "??????-????????-????????-??????-??-?-??.*" Then
            ReDim Preserve files(n)
            files(n) = file
            n = n + 1
        End If
        file = Dir
    Wend

    If n > 0 Then

        BubbleSort files
       
        'Add empty slot at end to facilitate loop end boundary
       
        ReDim Preserve files(n)
       
        'Move duplicate files
       
        numMoved = 0
        n = 0
        While n < UBound(files)
            Debug.Print "Keep " & files(n)
            i = n
            n = n + 1
            While n < UBound(files) And Left(files(n), 32) = Left(files(i), 32)
                Debug.Print "Move " & files(n)
                Name fromFolder & files(n) As toFolder & files(n)
                n = n + 1
                numMoved = numMoved + 1
            Wend
        Wend
       
        MsgBox numMoved & IIf(numMoved = 1, " file", " files") & " moved" & vbCrLf & _
               "from " & fromFolder & vbCrLf & _
               "to " & toFolder
       
    Else
   
        MsgBox "No matching files found in " & fromFolder
       
    End If
   
End Sub


Private Sub BubbleSort(data() As String)

    'Sort a one-dimensional string array in descending order
   
    Dim i As Long, j As Long
    Dim temp As String
   
    For i = LBound(data) To UBound(data) - 1
        For j = i + 1 To UBound(data)
            If data(i) < data(j) Then
                temp = data(i)
                data(i) = data(j)
                data(j) = temp
            End If
        Next
    Next
    
End Sub

 

[excel_newbie86]

Great code dear @John_w , you're verry kind when reply me alot times.

I've just add some code to check if "OLD" folder don't exist will create folder with name "OLD"

With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing duplicate files"
        .InitialFileName = ThisWorkbook.Path
        If Not .Show Then Exit Sub
        fromFolder = .SelectedItems(1) & "\"
        toFolder = fromFolder & "OLD\"
    End With
    
    If Dir(toFolder, vbDirectory) = "" Then
        MkDir toFolder
    End If

Thanks again and have a nice day.