SOLVED (thanks Damon!): Macro takes half a minute!

[SteveC]

I can't figure out why this event macro takes 35 seconds to finish.
It takes the input into AA1 and makes it uppercase; checks for a duplicate filename in the same folder & if it exists gives you a message; then changes the name of the file to match the contents of AA1. It also changes the sheet names from the input (year)into AK1.
Any suggestions?
Thanks for any help.
Steve

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Path As String ' path of current worksheet
Dim ThisFileNew As String ' new file name including path
Dim Resp As Integer ' user response to overwrite query
Dim i As Integer ' rename workSHEETS
Dim fname As String ' to DEL old file
fname = ActiveWorkbook.FullName ' to DEL old file

On Error GoTo errorhandler ' to resolve Run-time error "13":Type mismatch
If Target = Range("AK1") Then ' rename workSHEETS
For i = 1 To Worksheets.Count ' rename workSHEETS
Worksheets(i).Name = Target.Value + i - 1 ' rename workSHEETS
Next
End If
If Not Intersect(Target(1), Range("AA1")) Is Nothing Then
With Application
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next

' Set cell contents (file name) to upper case
Target.Value = UCase(Target.Text)

' Get current path (empty if workbook has never been saved)
Path = ThisWorkbook.Path
If Not Path = "" Then Path = Path & ""
ThisFileNew = Path & Target.Text & ".xls"
Resp = vbOK
' Check for existing file of same name and, if present, ask whether to overwrite
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.SearchSubFolders = False
.Filename = Target.Text & ".xls"
.MatchTextExactly = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If
End With
' Save the workbook if file does not exist, or if user wants to overwrite it
If Resp = vbOK Then
ActiveWorkbook.SaveAs Filename:=ThisFileNew
Kill fname ' to DEL old file
Else
Resp = MsgBox("You will need to rename this file manually", vbInformation)
End If

On Error GoTo 0
With Application
.DisplayAlerts = True
.EnableEvents = True
End With
End If
''''' Other code removed here''''''

End Sub
This message was edited by SteveC on 2002-08-23 00:52

 

[Damon Ostrander]

Hi Steve,

The FileSearch method is very powerful in its capability, but is also very slow. I suggest you replace

With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path
.SearchSubFolders = False
.Filename = Target.Text & ".xls"
.MatchTextExactly = False
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If
End With

with the following:

If Dir(ThisWorkbook.Path & "" & Target.Text & ".xls") <> "" Then
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If

 

[SteveC]

Damon,
Thank you, thank you!
You solved both problems - and in a more efficient piece of code.
Thanks for your help.
Steve

p.s. If you ever need any advice on frog racing, just let me know!