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

excel_newbie86

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
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
 

Attachments

  • 1.jpg
    1.jpg
    88.8 KB · Views: 4
  • 2.jpg
    2.jpg
    66.5 KB · Views: 5

Some videos you may like

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

excel_newbie86

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
Some one can help me or give some idea to do this.

thanks.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,609
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.

VBA Code:
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

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
Great code @John_w

VBA Code:
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,609

ADVERTISEMENT

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

Here is the complete code:

VBA 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

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,609

ADVERTISEMENT

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

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
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
VBA Code:
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,609
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.

VBA Code:
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

New Member
Joined
Aug 1, 2020
Messages
17
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
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"
VBA Code:
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,469
Messages
5,596,316
Members
414,053
Latest member
Dual Showman

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
Top