Error Trap

[TEB2]

I have 484 files in the same directory. I want to loop through all the
workbooks and add a sheet called "Memo".

I have the code to add the sheet. How do I handle the error when it already
has a sheet named "Memo" and go to the next file?

Here's the code I'm using:

Sub Memo_Test()

Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir

MyPath = "C:\Documents and Settings\Consultant\My
Documents\Partnerships\Carol Bynum\Test Files"
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

Set basebook = ThisWorkbook
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames, UpdateLinks:=0)

basebook.Worksheets("Sheet1").Copy
after:=mybook.Sheets(mybook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = basebook.Name
On Error GoTo 0
mybook.Close True
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub

 

[Gareth Roberts]

You can do this in a few ways. I would do it thus:
Sub Main1
'Open your file
Set wb = workbooks.open (myFileName)
'Check using the function below
If not fcnCheckWorkSheetAlreadyExists("Memo",wb ) then
'Add your worksheet
end if
End Sub

Function fcnCheckWorkSheetAlreadyExists(myName as string, wb as workbook) as
boolean
Dim sh as worksheet
on error resume next
set sh = wb.sheets(myName)
on error goto 0
If sh is nothing then exit Function
fcnCheckWorkSheetAlreadyExists1 = True
set sh = nothing
End Function

HTH,
Gareth

 

[Tom Ogilvy]

Sub Memo_Test()

Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir

MyPath = "C:\Documents and Settings\Consultant\My " & _
"Documents\Partnerships\Carol Bynum\Test Files"
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

Set basebook = ThisWorkbook
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames, UpdateLinks:=0)

basebook.Worksheets("Sheet1").Copy _
after:=mybook.Sheets(mybook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = basebook.Name
if err.number = 0 then
mybook.Close True
else
mybook.close False
end if
On Error goto 0
FNames = Dir()
Loop

CleanUp:
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub