PDA

View Full Version : get file paths based on name criteria from folder



syed_iqbal
02-12-2017, 05:02 AM
Hi,

On my desktop there is one folder (lets say) "Test". in that there are 10 files and those names are aaa,bbb,ccc,ddd,eee,fff,... so on. and in my worksheet there are 15 employee names (aaa,bbb,ccc,ddd,eee,fff,...) (from cell E2:E16). if we run vba code, all file paths should match with employee names like below

employee name file path

aaa C:\desktop\test\aaa.xlsx
bbb C:\desktop\test\bbb.xlsm
ccc C:\desktop\test\ccc.csv
ddd C:\desktop\test\ddd.xls
. .
. .
. .
. .

Thank you advance for your help.

regards
syed

Kenneth Hobs
02-12-2017, 10:02 AM
Sub Main()
Dim p$, fso As Object, r As Range, i&, f As Range, a

Set fso = CreateObject("Scripting.FileSystemObject")
p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Test\"
With fso
If Not .FolderExists(p) Then
MsgBox p & vbLf & "does not exist.", vbCritical, "Macro Ending"
Exit Sub
End If

Set r = Range("E2", Cells(Rows.Count, "E").End(xlUp))
a = aFFs(p, "/A-D")
For i = 0 To UBound(a)
Set f = r.Find(.GetBaseName(a(i)), Lookat:=xlWhole)
If Not f Is Nothing Then f.Offset(, 1).Value2 = a(i)
Next i
End With
r.Offset(, 1).EntireColumn.AutoFit
End Sub


'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found, aFFs() ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function