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!

 

[Norie]

I don't know if this helps but you don't actually need to select ranges to work with them.

As to your question about skipping files, I'm sure it must be possible somehow. I'll have a think about that and post back.

One thought is that you have a list of files already imported and you somehow search it when you do a new import.

Private Sub CopyFromEachFileInPath(SheetName, Path, Rng)
Dim TargSh As Worksheet
Dim TempSh As Worksheet

Dim fs, f, f1, fc, s, c As Long

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(Path & "\")
    Set fc = f.Files
    
    Application.ScreenUpdating = False
    
    ' make a temp sheet
    Range("B3:P60000").ClearContents
    
    Set TargSh = ActiveSheet
    Sheets.Add
    Set TempSh = ActiveSheet
    
    TargSh.Activate
    Application.ScreenUpdating = True
    
    For Each f1 In fc
        With 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).Formula = "='" & 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
                TargSh.Cells(NxRw, 1).Offset(0, 1).Paste
        End With
    Next ' workbook
    
    Columns("C:C").NumberFormat = "m/d/yyyy"
    Columns("K:K").NumberFormat = "$#,##0.00"
    Columns("B:O").HorizontalAlignment = xlCenter
    
    Range("A1").Select
    
    ' get rid of temp sheet
    Application.DisplayAlerts = False
    TempSh.Delete
    Application.DisplayAlerts = True
End Sub

 

[bigj4155]

Ahh bad habits that I never went back to fix. When copy/paste your code I got a error on this line.

TargSh.Cells(NxRw, 1).Offset(0, 1).Paste

No worries, corrected a few things and it runs the same just easier on the old eyes

What Im thinking is the value in Column O is the filename without the path and the ".xls" attached. So in human language :

If PDAhc\filename = Column "o" & ".xls" Then Next Filename
Else "rest of code"

like I said human language





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").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").NumberFormat = "m/d/yyyy"
Columns("K:K").NumberFormat = "$#,##0.00"
Columns("B:O").HorizontalAlignment = xlCenter
Range("A1").Select

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

 

[Norie]

Ahh bad habits that I never went back to fix. When copy/paste your code I got a error on this line.

TargSh.Cells(NxRw, 1).Offset(0, 1).Paste

That's my mistake.

Instead of what you changed it to I would try this.

TargSh.Cells(NxRw, 1).Offset(0, 1).PasteSpecial xlPasteAll

Like I said no need to select.

As for skipping files I'm still thinking about it, I didn't really work out exactly what the code is doing.

Perhaps you could explain in simple terms what's actually going on.

 

[bigj4155]

How to explain this... lets see.

Basically we have a template excel file that we will list different part numbers in and what they cost, how many ect... ect...

I then take all of the "important" data from this template and line the data up in row 4. A4:P4. I do this because our template changes from time to time but the data is always the same kind. So I can just change my reference. This file is then saved in my PDAhc directory.

Now when I open up PDAlookup.xls I run this macro and it goes through every file in pdahc and grabs A4:P4 and list them in pdalookup.xls!sheet1

Everytime the macro is ran it erases sheet1 and starts right under the header column. Lemme grab a snap shot of the pda lookup file.

PDAlookup.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	Back to Homepage
2	Open PDA	Tracking	Date	Carline	Year	Sku	Whse	Created By	Cost Center	Pieces	Cost	Responsibilty	Reason	Material Desc.	Case #	Case2#/Info	Case3#/Info
3	FBU5424	FBU5424	12/6/2005	D219	2005	5F9T14401XA	STA	User	520	2	$86.08	491	H=Release Decrease	FG - Production	SSTAC000000000	0	0
4	DCBU-4788	DCBU-4788	12/6/2005	LX	2006	05087332AE	STA	User	243	2	$93.92	254	A=Parts damaged during Rework	FG - Production	SSTAC000000000226740	0	0
5	FBU- 5521	FBU- 5521	12/9/2005	P221	2006	5L3T14358FH	STA	User	243	4	$42.12	254	A=Parts damaged during Rework	FG - Production	SSTAC000000000251232	0	0
Sheet1

O column is the filename without the path and the extension ".xls"
Then as you can see in Column A it just grabs the info in Column O and adds the directory and extension so the users can open whichever file they choose.

 

[Norie]

So is there only 1 row for each file?

 

[bigj4155]

Ya, the data is scattered throughout the template but for instance

Is cell A4 "=C8" then B4 "=h8" and C4 "=G7" and so on.

So when I run PDAlookup it just goes into each file and grabs A4:P4 instead of me pointing it to individual cells.

A4:P4 has the data I want in every file, this will never change.

Im going to tinker with it today, although I am not to effecient with vba so I will probably break more than improve Should be a learning experience today tho.

Here ya go, maybe this will tie it together for you:
P.S - im scratching my head on what the deal with the is all over the place. Makes it hard to read. *Fixed, just had to read the FAQ on it lol, cleaned up previous file post also*

SSTAC000000000FBU5449.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1
2
3	Tracking	Date	Carline	Year	Sku	Whse	Created By	Cost Center	Pieces	Cost	Responsibility	Reason	Material Description	Case #	Case2#/Info	Case3#/Info
4	FBU-5449	12/6/2005	D219	2005	5G1T13A625AC	STADTD	User Created	520	351.00	$207.09	491	H=Release Decrease	FG - Production	SSTAC000000000FBU5449	0	0
5
6
7	*Attention Inventory Analyst: If discrepancies are discovered in processing this document, contact the issuer for resolution.					Car Line:	D219	M/Y:	2005
8	Tracking #:		FBU-5449			Date Issued:		12/6/05
9	Component Part Number:					Date PDA Received:		12/6/05
10	Customer/Vendor Part Number:		5G1T13A625AC			Issued by:	User Created
11	Whse location/Qty:	STA	351	Bin Loc:		Issuing Cost Center:		520
12	Whse location/Qty:	DTD	7	Bin Loc:		Last Date Received:
Sheet1

 

[bigj4155]

Bump from the grave just to see if someone new has any input. Thanks for your attempt Norie!

 

[parmel]

I have a question / suggestion.

In the following few lines from your code you turn off screen updating and then turn it back on. I can't see why you need to do that. I'd leave it turned off. That will definitely make your code run faster.

' 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 'why turn it back on?

 

[bigj4155]

Ahhh, well there is a semi good reason for that Basically I did place that there for a reason. When I leave screen updating off for the entire code it does run a smig faster "maybe 2% faster, not much" but if the process takes say 5 mins to read every file and post its results, excel APPEARS to be locked during this process.

In short I had people thinking the worksheet had locked up and they proceeded to close it through task manager ect...

This way it turns screen updating off only during the flip flop from temp sheet to copy to sheet1. So your screen doesnt go crazy, instead you get a nice flow of rows as it updates from each file. Its kinda like a status bar

I do believe that screen updating will have to be turned off and will have more of a impact once there are more files to add. Hopefully I can figure something out before I get to that point tho