excel - Get Folder Names from server directory -
i need folder names path need search directory in server 6000 folders. have following snippet of code run through folder , folder names path. works fine in local directory when run same code on server directory fails after printing 86 folder names. code fails when run on server location more 6000 folders.
private sub printfolders() dim objfso object dim objfolder object dim objsubfolder object dim integer application.statusbar = "" 'create instance of filesystemobject set objfso = createobject("scripting.filesystemobject") 'get folder object set objfolder = objfso.getfolder("c:\temp") = 1 'loops through each folder in directory , prints names , path on error goto handlecancel application.enablecancelkey = xlerrorhandler msgbox "this may take long time: press esc cancel" each objsubfolder in objfolder.subfolders application.statusbar = objsubfolder.path & " " & objsubfolder.name 'print folder name cells(i + 1, 1) = objsubfolder.name 'print folder path cells(i + 1, 2) = objsubfolder.path = + 1 next objsubfolder handlecancel: if err = 18 msgbox "you cancelled" end if end sub
after discussion here final code works correctly, works great.
sub printfolders() dim wb workbook dim ws worksheet dim objfso object dim objfolder object dim objsubfolder object dim integer dim folder_name string application.screenupdating = false application.calculation = xlcalculationmanual application.statusbar = "" on error goto cleanfail set wb = thisworkbook set wscontrol = wb.sheets("control"): set wsoutput = wb.sheets("output") folder_name = wscontrol.cells(1, 2) if folder_name = "" msgbox "path location not entered. please enter path" wscontrol.cells(1, 2).select end end if set objfso = createobject("scripting.filesystemobject") set objfolder = objfso.getfolder(folder_name) = 1 dim myarr() variant redim myarr(1 i, 1 2) application.enablecancelkey = xlerrorhandler const iterationstoupdate integer = 10 each objsubfolder in objfolder.subfolders myarr(i, 1) = objsubfolder.name myarr(i, 2) = objsubfolder.path = + 1 myarr = application.transpose(myarr) redim preserve myarr(1 2, 1 i) myarr = application.transpose(myarr) if mod iterationstoupdate = 0 application.statusbar = objsubfolder.path & " " & objsubfolder.name doevents end if next objsubfolder application.statusbar = "" wsoutput.rows("2:1048576").delete dim destination range set destination = wsoutput.range("a2") destination.resize(ubound(myarr, 1), ubound(myarr, 2)).value = myarr wsoutput.columns.entirecolumn.autofit: wsoutput.usedrange.horizontalalignment = xlcenter wsoutput.activate msgbox ("done") cleanexit: application.statusbar = false application.statusbar = "" application.cursor = xldefault application.screenupdating = true application.calculation = xlcalculationautomatic exit sub cleanfail: const msgtitle string = "operation not completed" if err.number = 18 msgbox "operation cancelled.", vbinformation, msgtitle else msgbox "an error has occurred: " & err.description, vbcritical, msgtitle end if resume cleanexit end sub