Make this code run faster?

[bigj4155]

Hello everyone!

Hope everyone is having a good and relaxed holiday season! I have a situation that I can see running into problems down the road, so I am trying to solve it now.

Basically I have a directory filled with identical worksheets "layout wise" with different vales entered into the template. I then have a worksheet that runs code that goes through each worksheet in my directory and returns the values listed in A4:P4. The code is working wonderful, however as the directory grows in size and more worksheets are added the process of extracting this information is getting pretty slow. Currently there is only some 500 files in the directory and it takes roughly 2 minutes extract the information. However we will soon be adding around 200 new files a month. So in 5 months of so I can see this taking a very long time Anyway here is my code that I use now.



Public Sub GetDirXlsContents()
' Source sheet name, Source directory path, Source cell Range
Call CopyFromEachFileInPath("PDATemplate", "L:\Shared\YNAGC INVNTRY\STAINV\STAPDA\PDAhc", "A4:P4")
End Sub

Private Sub CopyFromEachFileInPath(SheetName, Path, Rng)
Dim fs, f, f1, fc, s, c As Long
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Path & "\")
Set fc = f.Files

' make a temp sheet
Range("B3:P60000").Select
Selection.ClearContents
Application.ScreenUpdating = False
TargSh = ActiveSheet.Name
Sheets.Add
TempSh = ActiveSheet.Name
Sheets(TargSh).Activate
Application.ScreenUpdating = True

For Each f1 In fc
With Sheets(TempSh)

' clear temp sheet and start again
.Cells.ClearContents

' Place Src Info on Temp Targ Sheet
If Right(f1.Name, 3) = "xls" Then
fName = Left(f1.Name, Len(f1.Name) - 4)
.Range(Rng).FormulaArray = "='" & Path & "\[" & fName & "]" & SheetName & "'!" & Rng
.Range(Rng).Value = .Range(Rng).Value

'GetValuesFromAClosedWorkbook Path, f1.Name, SheetName, "A1:J500"
End If

NxRw = Workbooks("PDAlookup.xls").Sheets("Sheet1").Range("B1000").End(xlUp).Row + 1
.Range("A4:P4").Copy
Sheets(TargSh).Cells(NxRw, 1).Offset(0, 1).Select
ActiveSheet.Paste
End With
Next ' workbook

Columns("C:C").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("K:K").Select
Selection.NumberFormat = "$#,##0.00"
Columns("B:O").Select
With Selection
.HorizontalAlignment = xlCenter
End With
Range("A1").Select

' get rid of temp sheet
Application.DisplayAlerts = False
Sheets(TempSh).Delete
Application.DisplayAlerts = True
End Sub

So when new files are added, we run this code, build the table from it and then save the worksheet. Is there a way to maybe, if the file is already listed skip line and continue? Would this even speed the process up?

Thanks all!

 

[Fritz]

Hi

I don't know if this is related bigj4155 but I have a bit of code that used to open a series of workbooks in a directory and copy the worksheet from each to the main workbook, rename the sheet then close the workbook - 12 times. I have changed the workbooks now so they have 2 worksheets in each to copy and it is really SLOW!. I have noticed that when debugging and stepping through with F8 that the .Name line gets slower each time the line in run. I don't yet know how to cure this, but it may explain your problem

Fritz

    For Counter = 2 To UpdateLastrow
        WorkBookToUpdate = FolderBPInfo(Counter, 1)
        AccountName = FolderBPInfo(Counter, 2)
        FullPathName = FolderPath & "\" & WorkBookToUpdate
        'open workbook without asking for password or any forms being    displayed
        Application.EnableEvents = False
        Workbooks.Open FileName:=FullPathName, ReadOnly:=True
        Application.EnableEvents = True
        Application.StatusBar = "***    Currently loading the lastest " & AccountName & " Buying Plan   ***"
        'Workbooks(WorkBookToUpdate).Sheets(BPSheetNameThisYear).Select
        Workbooks(WorkBookToUpdate).Sheets(BPSheetNameThisYear).Copy After:=Workbooks("Group Sales Forecast.xls").Sheets(1)
        Workbooks("Group Sales Forecast.xls").Sheets(BPSheetNameThisYear).Name = FolderBPInfo(Counter, 4) & ThisYear
        
        Workbooks(WorkBookToUpdate).Sheets(BPSheetNameNextYear).Copy After:=Workbooks("Group Sales Forecast.xls").Sheets(1)
        Workbooks("Group Sales Forecast.xls").Sheets(BPSheetNameNextYear).Name = FolderBPInfo(Counter, 4) & NextYear
        Workbooks(WorkBookToUpdate).Close
    Next Counter