(Solved) – VBA Excel Program taking hours [closed]


This my program to change the formatting of sheets in different folders, I have over 5000 files in one folder it is taking up to three hrs for one folder & there are multiple subfolders in the main folder. I want to cut down this time to 10 mins or as fast as possible..any idea regarding modification of code will be really beneficial. Here is my code:

Sub loopAllSubFolderSelectStartDirectory()

'Another Macro must call LoopAllSubFolders Macro to start to procedure
Call LoopAllSubFolders("D:HTTP")

End Sub
'Don’t run the following macro, it will be called from the macro above:

'List all files in sub folders
Sub LoopAllSubFolders(ByVal folderPath As String)

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

Set wc = ActiveWorkbook
If Right(folderPath, 1) <> "" Then folderPath = folderPath & ""
fileName = Dir(folderPath & "*.*", vbDirectory)

While Len(fileName) <> 0

    If Left(fileName, 1) <> "." Then

        fullFilePath = folderPath & fileName

        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders   1


Set wb = Workbooks.Open(fullFilePath)
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant

fnd = "<*>"
rplc = ""

For Each sht In wb.Worksheets
On Error GoTo 0
  sht.Cells.Replace what:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
    Next sht

Workbooks("New file to be saved.xlsm").Sheets("Sheet1").Range("A1:T1").Copy

'Now, paste to y worksheet:
Range("G2:H100").Cut Range("Q2:R100")
Range("B2:F100").Cut Range("F2:J100")

'With wb.ActiveSheet.Range("A1:T1").Interior
'        .Pattern = xlSolid
'        .PatternColorIndex = xlAutomatic
'        .ThemeColor = xlThemeColorDark1
'        .TintAndShade = -0.149998474074526
'        .PatternTintAndShade = 0
'    End With
'    With wb.ActiveSheet.Range("A1:T1").Font
'        .ThemeColor = xlThemeColorLight2
'        .TintAndShade = 0
'    End With
'    Range("A1:T1").Font.Bold = True

    wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), FileFormat:=xlExcel8
wb.Close True
Kill fullFilePath
            'Insert the actions to be performed on each file
            'This example will print the full file path to the immediate window
            'Debug.Print folderPath & fileName

        End If

    End If
fileName = Dir()


For i = 0 To numFolders - 1

    LoopAllSubFolders folders(i)

Next i

End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *