What are some Methods of Improving Performance

Background: We utilize a NAS to store specific file(s) for our users. Unfortunately the NAS is not setup for auditing so I have to perform auditing myself.  We are constantly running into space problems that requires me to run this script to audit the file types stored on the NAS. I have to run this script locally on my laptop vs. on a server running on a 32-bit OS.
 
Issue: This netowrk path current contains almost 2700 folders.  Under those folder there are countless subfolders/files that can be quite large (multi Gig). Writing to a CSV log file took long enough but I recently modified the code to write the log file to an Excel file which is not taking longer. Right now it is taking about 30 hours to complete this one script.
 
Question: What is the best way to impove performance so that I can get this report a little quicker?  One thought is to read the folders and split them up and somehow run two scripts simultaneously.  Not very efficient since two log files will be created but it's an option.  Maybe I need to re-org the code and use some other syntax that I am unaware of?  Any thoughts would be much appreciated.  I've inlcuded code below as a reference.
 


 Option Explicit
On Error Resume Next   ' Identify Variables
Dim strStartDir, strLogFile, strFormatDate, intDate2, intCount, intFolderSize, intNonPST, intOKFile, x, y, i
Dim intFileCount, intSubCount, intRow, intRow2
Dim arrFileDetail()
Dim FSO, objDir, objSubFolder
Dim objExcel, objWorkbook, objWorksheet1, objWorksheet2   ' Assign Variables
x = 0: y = 0: intRow = 1: intRow2 = 1
strStartDir = "M:\"
strFormatDate = Replace(Date,Chr(47),Chr(95))
strLogFile = "T:\tacom\ilsc\Team\Public\M_Drive_log\" & strFormatDate & "-MDrive.xlsx"   ' Initiate Log File in Excel
' Write out the headers and Format pages Set FSO = CreateObject("Scripting.FileSystemObject")
Set objExcel = CreateObject("Excel.Application")
 If Err.Number <> 0 Then
  On Error GoTo 0
  WScript.Echo "Excel application not found."
  WScript.Quit
 End If
objExcel.DisplayAlerts = False
Set objWorkbook = objExcel.Workbooks.Add
Set objWorksheet1 = objWorkbook.Worksheets(1)
Set objWorksheet2 = objWorkbook.Worksheets(2) objWorksheet1.Cells(1,1).value = "Directory Path"
objWorksheet1.Cells(1,2).value = "Total File(s)"
objWorksheet1.Cells(1,3).value = "SubFolder(s)"
objWorksheet1.Cells(1,4).value = "Outlook under 2 yr Policy"
objWorksheet1.Cells(1,5).value = "Folder Size (GB)"
objWorksheet1.Cells(1,6).value = "Noncompliant Files"
objWorksheet1.Cells(1,7).value = "Noncompliant File Size (KB)"
objWorksheet1.Cells(1,8).value = "Start Time"
objWorksheet1.Cells(1,9).value = Now
objWorksheet2.Cells(1,1).value = "File Name"
objWorksheet2.Cells(1,2).value = "Last Modified"
objWorksheet2.Cells(1,3).value = "File Size"
objWorksheet1.Range("B1:H1").WrapText = True
objWorksheet1.columns("A").ColumnWidth = 22
objWorksheet1.columns("B").ColumnWidth = 6
objWorksheet1.columns("C:D").ColumnWidth = 8.5
objWorksheet1.columns("E").ColumnWidth = 13
objWorksheet1.columns("F").ColumnWidth = 8.5
objWorksheet1.columns("G:H").ColumnWidth = 13
objWorksheet2.columns("A").ColumnWidth = 85 
Set objDir = FSO.GetFolder(strStartDir)
Err.Clear
For Each objSubFolder In objDir.SubFolders
 On Error Resume Next
 intRow = intRow + 1
 If Err <> 0 Then
  objWorksheet1.Cells(intRow,8) = "Error Acessing " & objSubFolder.Path
  objWorksheet1.Cells(intRow,9) = Err.Number
  objWorksheet1.Cells(intRow,10) = Err.Description
  WScript.Echo "Error Accessing "  & objSubFolder.Path & " | " & err.Number & " | " & err.Description
  Err.Clear
 Else
  intFolderSize = objSubFolder.Size
  GetInfo(objSubFolder)
  objWorksheet1.Cells(intRow,1) = objSubFolder.Path
  objWorksheet1.Cells(intRow,2) = intFileCount
  objWorksheet1.Cells(intRow,3) = intSubCount
  objWorksheet1.Cells(intRow,4) = intCount
  objWorksheet1.Cells(intRow,5) = FormatNumber(objSubFolder.Size/2^30,2)
  objWorksheet1.Cells(intRow,6) = intFileCount - (intCount + i)
  objWorksheet1.Cells(intRow,7) = FormatNumber(((objSubFolder.Size - intOKFile)/2^10),2)
  
  WScript.Echo objSubFolder.Path & Chr(44) & intSubCount & Chr(44) & intFileCount
  For i = 0 To y - 1
   intRow2 = intRow2 + 1
   objWorksheet2.Cells(intRow2,1) = arrFileDetail(0,i)
   objWorksheet2.Cells(intRow2,2) = arrFileDetail(1,i)
   objWorksheet2.Cells(intRow2,3) = arrFileDetail(2,i)
   WScript.Echo arrFileDetail(0,i) & Chr(9) & arrFileDetail(1,i)& Chr(9) & arrFileDetail(2,i)
  Next
  intCount = 0: y = 0: i = 0
  intFileCount = 0: intSubCount = 0: intNonPST = 0: intOKFile = 0
  arrFileDetail.Clear  End If
Next objWorksheet1.Cells(intRow + 1,1) = "M Drive Capacity:"
objWorksheet1.Cells(intRow + 1,2) = FormatNumber(objDir.Drive.TotalSize,0)
objWorksheet1.Cells(intRow + 1,3) = "Free Space Available"
objWorksheet1.Cells(intRow + 1,4) = FormatNumber(objDir.Drive.AvailableSpace,0)
objWorksheet1.Cells(intRow + 1,5) = "Space Used"
objWorksheet1.Cells(intRow + 1,6) = FormatNumber(objDir.Drive.TotalSize - objDir.Drive.AvailableSize,0)
objWorksheet1.Cells(intRow + 1,7) = "End Time"
objWorksheet1.Cells(intRow + 1,8) = Now objExcel.ActiveWorkbook.SaveAs strExcelFile
objExcel.Application.Quit   Set objDir = Nothing
Set FSO = Nothing WScript.Echo "DONE"   '******************************************************************************
' Look at each file in the specified directory to determine the file type.
' Find all "Outlook related" files older than 2 years old and report those files.
'******************************************************************************
Sub GetInfo(strCurrentDir)
 Dim objSubDir, objSubFile, objSubF  Set objSubDir = FSO.GetFolder(strCurrentDir)
 Err.Clear
 For Each objSubFile In objSubDir.Files ' objSubFile.Path
  intSubCount = intSubCount + objSubDir.SubFolders.Count
  intFileCount = intFileCount + objSubDir.Files.Count
  If Err <> 0 Then
   WScript.Echo "Error Accessing "  & err.Number & " | " & err.Description & " | " & objSubFile.Name
   Err.Clear
  ElseIf LCase(Right(CStr(objSubFile.Name), 3)) = "pst" Or LCase(Right(CStr(objSubFile.Name), 3)) = "ost"_
  Or LCase(Right(CStr(objSubFile.Name), 3)) = "msg" Or LCase(Right(CStr(objSubFile.Name), 3)) = "pab"_
  Or LCase(Right(CStr(objSubFile.Name), 7)) = "pst.tmp" Then
   intOKFile = intOKFile + objSubFile.Size
   intDate2 = CLng(DateDiff("yyyy",objSubFile.DateLastModified,Date))
   If intDate2 > 2 Then
    ReDim Preserve arrFileDetail(2,y)
    arrFileDetail(0,y) = objSubFile.Path & chr(92) & objSubFile.Name
    arrFileDetail(1,y) = objSubFile.DateLastModified
    arrFileDetail(2,y) = FormatNumber(objSubFile.Size,0)
    y = y + 1
   Else
    intCount = intCount + 1
   End If
   intDate2 = 0
  End If
 Next  For Each objSubF In objSubDir.SubFolders
  GetInfo(objSubF)
 Next
 Set objSubDir = Nothing
 Set objSubFile = Nothing End Sub   '******************************************************************************
' Function checks data in strData for a comma.  If a comma is found Then
'  quotes are added to the beginning and the end of the data and returned.
'  If no comma is found then the original data is returned
'******************************************************************************
Function ReturnFormattedData(strData)
 Dim strReturn
 If InStr(strData, ",") > 0 Then
  strReturn = Chr(34) & strData & Chr(34)
 Else
  strReturn = strData
 End If
 ReturnFormattedData = strReturn
End Function 

Didn't look at it too much, but I would suggest that you change your code where you check the file extension.  Currently, you are passing it through 3 functions that isn't necessary.  Get the extension from it and lower case it at the same time.  You don't really need to recast it as a string as it already is a string.  I would also you a Select statement to make it look cleaner. 
 
 

 
Const sTestFile = "C:\WINNT\Test me.ost" 
Dim sFileExt : sFileExt = LCase(Right(sTestFile, 3)) 
  
Select Case sFileExt 
 Case "pst", "ost", "msg", "pab" 
  Msgbox sFileExt & " found!" 
 Case Else 
  Msgbox "No Match!" 
End Select 
  

 
Also, you could use the FileSystemObject GetExtensionName method since you already have the object created.
 
 

 
Const sTestFile = "C:\WINNT\Test me.pst" 
Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject") 
Dim sFileExt : sFileExt = LCase(oFSO.GetExtensionName(sTestFile))
  
  
Select Case sFileExt 
 Case "pst", "ost", "msg", "pab" 
  Msgbox sFileExt & " found!" 
 Case Else 
  Msgbox "No Match!" 
End Select 

 
I don't know how much time this would actually save as I haven't tested it.  It may help some though.