Sheet Exists Add Sheet

[goss]

Hi all,

Using Excel 2010

I am trying to test if a sheet exists, if not, add a sheet
When I comment out the On Error Resume Next I receive Subscript Out Of Range error.
If I leave the On Error Resume Next 2 sheets are added (should be 4)
And the Filter Copy Paste part outputs the wrong data onto the two sheets that are added

Any ideas?

thx
w

Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
Option Explicit
Sub FilterSplit()

    'Start timer
     Dim t As Long
     t = GetTickCount
     
    'Purpose:
    '1.) Find matching combinations
    '
    'Date       Developer       Action          Comment
    '------------------------------------------------------------------------------
    '03/03/13   ws              Created
    '03/03/13   ws              Modified        Split to different worksheets
    
    'Excel environment - Turn off system settings - Increase speed
     With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
     End With
     
    'Declare variables
     Dim wb As Workbook
     Dim ws As Worksheet
     Dim wsData As Worksheet
     Dim wsCriteria As Worksheet
     Dim wsDestination As Worksheet
     Dim rngCombine As Range
     Dim rngCopy As Range
     Dim rngDestination As Range
     Dim lRowsTrxData As Long
     Dim lRowsCriteria As Long
     Dim lRowsDestination As Long
     Dim lFirstRow As Long
     Dim lLastRow As Long
     Dim strTime As String
     Dim sCombineFrmla As String
     Dim sCriteria As String
     Dim sTrimCriteria As String
     Dim bFlag As Boolean
     Dim bSheetExists As Boolean
     
    'Initialize variables
     Set wb = ThisWorkbook
     Set wsData = wb.Worksheets("TrxData")                      '<-- Data set to be filtered
     Set wsCriteria = wb.Worksheets("MatchList")                '<-- Criteria for filter
     sCombineFrmla = "=A2&"" - ""&B2"
     bFlag = True
     
    'Remove filter from trx data
     With wsData
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
     End With
         
    'Add formula to TrxData to create Part Vendor combinations
     With wsData
        lRowsTrxData = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngCombine = .Range("E2:E" & lRowsTrxData)
        rngCombine.Formula = sCombineFrmla
        rngCombine.Copy
        .Range("E2").PasteSpecial (xlPasteValues)
        .[E1].Formula = "Combined"
     End With
    
    'Get last row on criteria sheet - use this for number of times to loop
     With wsCriteria
        lRowsCriteria = .Cells(Rows.Count, 1).End(xlUp).Row
     End With
     
    'Loop through the criteria
     Do While lRowsCriteria >= 2    'Ignores header row
     
        'Get criteria to filter for
         With wsCriteria
            sCriteria = .Range("C" & lRowsCriteria).Value
         End With
    
        'Get size of data source to be filtered
        'Assumes data is in Col A:E - update as needed
         With wsData
            Set rngCopy = .Range("A1:E" & lRowsTrxData)
         End With
         
        'Set the destination range where matching data will be copied to
        'Test to see if additional sheet need to be added - if so, add them
        With wb
            sTrimCriteria = Replace(sCriteria, " ", "")
'            On Error Resume Next
            Set ws = .Worksheets(sTrimCriteria)
'            On Error GoTo 0
            If Not ws Is Nothing Then
                ws.UsedRange.ClearContents
            Else
                .Sheets.Add , _
                After:=.Worksheets(Worksheets.Count)
                ActiveSheet.Name = sTrimCriteria
            End If
            Set ws = Nothing
            Set ws = .Worksheets(sTrimCriteria)
            With ws
                Set rngDestination = .Range("A1")
            End With
        End With
         
        'Filter the data based on the criteria
        'The field being filtered here is 5 (E) - Update as needed
         With rngCopy
            .AutoFilter , _
                Field:=5, _
                Criteria1:=sCriteria
         End With

        'Use Offset(1, 0) to disregard header row
        'Remove Offset(1, 0) to include the header row
         With wsData
            .UsedRange.Offset(1, 0).Copy Destination:=rngDestination
         End With
    
        'Remove filters
         With wsData
            If .AutoFilterMode Then
                .AutoFilterMode = False
            End If
         End With
         
         bFlag = False                               '<--Update loop flag
         lRowsCriteria = lRowsCriteria - 1      '<--Update counter
    Loop

    'Tidy Up
     'Destroy objects
      Set rngCombine = Nothing
      Set rngCopy = Nothing
      Set rngDestination = Nothing
      Set ws = Nothing
      Set wsData = Nothing
      Set wsCriteria = Nothing
      Set wsDestination = Nothing
      Set wb = Nothing
     
    'Restore Excel environment
     With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
     End With
     
    'Timer
     MsgBox GetTickCount - t & " Milliseconds", , " Milliseconds"

End Sub

[arlu1201]

See if this works for you -

If Not Evaluate("ISREF(Sheet3!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Sheet3"
End If

[goss]

See if this works for you -

If Not Evaluate("ISREF(Sheet3!A1)") Then
    Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Sheet3"
End If

Thanks,
It worked when the sheet did not exist, but errored out when the sheet did exist here

         With wsData
            .UsedRange.Offset(1, 0).Copy Destination:=rngDestination
         End With

I also tried replacing the string to be evaluated

If Not Evaluate("ISREF" & sTrimCriteria & "!A1") Then

Seems to be an ok string but I receiving this error message

Run-time error '13':
Type mismatch

Thanks

[arlu1201]

Can you attach a sample file so i can test?

[goss]

Thanks.

The file is attached.

[Norie]

Try this.

You'll need to declare Res as Variant.

      Res = Evaluate("ISREF" & sTrimCriteria & "!A1")
      If IsError(Res) Then
          Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = sTrimCriteria
      End If
      Set ws = .ActiveSheet

[mc84excel]

I am trying to test if a sheet exists, if not, add a sheet

Does this work?

Public Function AddSheetIfNotExist(SheetName As String)
    On Error GoTo NoSuchSheet
    If Len(Sheets(SheetName).Name) > 0 Then
        Exit Function
    End If
NoSuchSheet:
    'If it doesn't work, check to see if workbook is protected or read-only file
    Sheets.Add.Name = SheetName
End Function

Sub testtheaddsheetifnotexist()
    'your code here
    Call AddSheetIfNotExist("Index") 'change "Index" to what you want the sheet name to be
    'your code here
End Sub