Asked this question a month or so ago and am still struggling with this problem.
The following code recursively searches a folder and its subfolder for all duplicate and unique files and prints folder path, file name and a custom property (cad file property). My issue is when calling the custom property, it prints the Title of the property instead of the property e.g. Name instead of 123456.doc or Size instead of 53kb
AttribName is currently set to 327 as this is where my custom property is found but no matter what that is set to, the result is the same. If set to 3, Date modified, it will print "Date modified" rather than the date.
Sub FindDuplicateFiles()
Dim pth1 As Variant
Dim arrd() As Variant
Dim arru() As Variant
ReDim arrd(0 To 2, 0)
ReDim arru(0 To 2, 0)
'Ask for first folder (path)
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
pth1 = .SelectedItems(1) & "\"
End With
'Insert a new sheet
Sheets.Add
Set x = ActiveSheet
'Get a list of first folder´s content to a sheet
Application.ScreenUpdating = False
x.Range("A1") = "Duplicate files"
x.Range("A2") = "Path"
x.Range("B2") = "File name"
x.Range("C2") = "Description"
x.Range("A:F").Font.Bold = False
x.Range("A1:C2").Font.Bold = True
'Fetch files
Recursive pth1
'Sort list
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
'Transfer range to array
arr1 = x.Range("A3:C" & Lrow).Value
'Clear sheet
x.Range("A3:C" & Lrow).Clear
'chk = False
For r1 = LBound(arr1, 1) + 1 To UBound(arr1, 1)
If arr1(r1, 2) = arr1(r1 - 1, 2) Then
'Save previous value to a dupes array
arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
'Erase previous value
arr1(r1 - 1, 1) = ""
arr1(r1 - 1, 2) = ""
arr1(r1 - 1, 3) = ""
chk = True
Else
If chk = True Then
'Save previous value to a dupes array
arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
chk = False
ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
'Erase previous value
arr1(r1 - 1, 1) = ""
arr1(r1 - 1, 2) = ""
arr1(r1 - 1, 3) = ""
Else
'Save previous value to a uniques array
arru(0, UBound(arru, 2)) = arr1(r1 - 1, 1)
arru(1, UBound(arru, 2)) = arr1(r1 - 1, 2)
arru(2, UBound(arru, 2)) = arr1(r1 - 1, 3)
ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
'Erase previous value
arr1(r1 - 1, 1) = ""
arr1(r1 - 1, 2) = ""
arr1(r1 - 1, 3) = ""
End If
End If
Next r1
'Last value
If chk = True Then
arrd(0, UBound(arrd, 2)) = arr1(r1 - 1, 1)
arrd(1, UBound(arrd, 2)) = arr1(r1 - 1, 2)
arrd(2, UBound(arrd, 2)) = arr1(r1 - 1, 3)
Else
arru(0, UBound(arru, 2)) = arr1(r1 - 1, 1)
arru(1, UBound(arru, 2)) = arr1(r1 - 1, 2)
arru(2, UBound(arru, 2)) = arr1(r1 - 1, 3)
End If
'Return duplicate values to sheet
x.Range("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = Application.Transpose(arrd)
x.Range("A" & UBound(arrd, 2) + 3) = "Unique files"
x.Range("A" & UBound(arrd, 2) + 4) = "Path"
x.Range("B" & UBound(arrd, 2) + 4) = "File name"
x.Range("C" & UBound(arrd, 2) + 4) = "Size"
x.Range("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).Font.Bold = True
x.Range("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) = Application.Transpose(arru)
'Autofit cell width
x.Columns("A:C").AutoFit
End Sub
Sub Recursive(FolderPath As Variant)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
Dim AttribName As String
AttribName = 327
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace(FolderPath)
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
Else
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = FolderPath
ActiveSheet.Range("B" & Lrow) = Value
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(Value, AttribName)
End If
End If
Value = Dir
Loop
For Each Folder In Folders
Recursive FolderPath & Folder & "\"
Next Folder
End Sub
I can Substitute the following Sub for the last which does what I need it to but its incredibly slow, approx 15mins for 3000 files, whereas the original runs in around 1 min for the same amount of files.
Sub Recursive(FolderPath As Variant)
'Show Filename, Attribute Name and Attribute Value in Columns B,C,D
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace(FolderPath)
Dim AttribName As Long
'AttribName = InputBox(Prompt:="Enter Attribute Value (0-266).")
AttribName = 327
'Insert a new sheet
Sheets.Add
Set x = ActiveSheet
'Get a list of first folder´s content to a sheet
Application.ScreenUpdating = False
x.Range("A1") = "Files"
x.Range("A2") = "Path"
x.Range("B2") = "File Name"
x.Range("C2") = "Description"
x.Range("A:F").Font.Bold = False
x.Range("A1:C2").Font.Bold = True
For Each sFile In oDir.Items
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
ActiveSheet.Range("A" & Lrow) = oDir.GetDetailsOf(sFile, 191)
ActiveSheet.Range("B" & Lrow) = oDir.GetDetailsOf(sFile, 0)
ActiveSheet.Range("C" & Lrow) = oDir.GetDetailsOf(sFile, AttribName)
Next
Columns("A:M").AutoFit
ActiveSheet.Range("A:M").HorizontalAlignment = xlLeft
End Sub
