Create New sheet VBA code not working

[Vincent88]

Hi, I got help from a experienced member here to rectify my code and it resolves my issue. However my another function seems having conflict with the suggested code. Can someone help me to correct it !
My file is attached Excel file
When I run module 1, I debugged to get NEXT C in module 4 keep looping and it could not proceed further.

'Module 1

Sub CheckSheet()
    Application.ScreenUpdating = False
    Dim szToday As String
    szToday = Format(Date, "d mmm yyyy")
    If Not Evaluate("isref('" & szToday & "'!A1)") Then
        Call BlankSheet
        Call Module2.RemoveOldSheets
    Else
        'MsgBox "Sheet " & szToday & " exists."
      Dim AckTime As Integer, InfoBox As Object
         Set InfoBox = CreateObject("WScript.Shell")
         AckTime = 1
         Select Case InfoBox.Popup("Sheet " & szToday & " exists.", AckTime, "Notification", 0)
         Case 1, -1
         Exit Sub
         End Select
      
    End If
    Application.ScreenUpdating = True
End Sub

'https://www.mrexcel.com/board/threads/copy-table-headers-from-current-sheet-to-newly-created-sheet-in-excel-vba.1169715/
Sub BlankSheet()
  Dim ws As Worksheet
  Dim LastColumn As Long
  Dim strSheetName As String

  If ActiveWorkbook Is ThisWorkbook Then
    Set ws = ActiveSheet
 
    LastColumn = ws.Range("A1").CurrentRegion.Columns.Count
 
    On Error Resume Next
    'ADD
    Application.DisplayAlerts = False
    
    ws.Copy before:=ActiveSheet
    strSheetName = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = strSheetName
    
    'MODIFIED
    'On Error GoTo 0
     Application.DisplayAlerts = True
 
    'Clear All Contents
    'Application.EnableEvents = False
        
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
      .ListObjects.Add(xlSrcRange, .Range("A1").Resize(2, LastColumn), , xlYes).Name = strSheetName
      .ListObjects(strSheetName).TableStyle = "TableStyleMedium2"
      .ListObjects(strSheetName).ShowAutoFilterDropDown = False
    End With
    
    'Application.EnableEvents = True
    Set ws = Nothing
    g_blnWbkShtSelChange = False
    
  End If

End Sub


'Module 2

Sub RemoveOldSheets()
  Dim Sh As Worksheet
  For Each Sh In Worksheets
    If Len(Sh.Name) >= 10 Then
      If Date - CDate(Left(Sh.Name, 11)) >= 60 Then
        Application.DisplayAlerts = False
        Sh.Delete
        'MsgBox "Old Sheets deleted"
        Application.DisplayAlerts = True
      End If
    End If
  Next Sh
End Sub


'Module 4

Public Function IsPartOfListObject(ByVal argRange As Range) As Boolean
    Dim c As Range
    For Each c In argRange
        If Not c.ListObject Is Nothing Then
            IsPartOfListObject = True
            Exit For
        End If
    Next c
End Function


Public Function IsCurrentSheet(ByVal argSht As Worksheet, ByVal argSheetNames As String) As Boolean
    IsCurrentSheet = (CBool(InStr(LCase(argSheetNames), LCase("/" & argSht.Name & "/"))))
End Function

 

[Zot]

The line calling the Function is in Workbook Module
If Not IsPartOfListObject(Target) Then Exit Sub

The Target is referring to a single cell. The Function
Public Function IsPartOfListObject(ByVal argRange As Range) As Boolean

keeps looping because the statement
If Not c.ListObject Is Nothing
is is resulting False all the time since you are looping a single range Target. Not sure what you were trying to do. Why you were looping a single cell. You will never get out of the loop since the result is the same all the time

 

[Vincent88]

Hi Zot,
This is the code in workbook mode. Module 4 is added in order to make Format Column A function works but it has side effect in module 1 & 2 which I want to duplicate worksheet and remove some old worksheets.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    ' >> do not perform any action on sheet named Agents <<
    If StrComp(Sh.Name, "Agents", vbTextCompare) = 0 Then Exit Sub

    ' check whether Target is part of a worksheet table using a custom function
    If Not IsPartOfListObject(Target) Then Exit Sub

    With Target
        If .CountLarge > 1 Or .Column > 4 Or .Row = 1 Then Exit Sub

        Application.EnableEvents = False

        If InStr(1, Cells(.Row, "A").Text, "REQ") > 0 And Cells(.Row, "B").Text <> vbNullString Then
    
            Cells(.Row, "D").ShrinkToFit = True
            Cells(.Row, "C").HorizontalAlignment = xlRight
            Cells(.Row, "C").Value = ActiveSheet.Name
            .Parent.Range("A" & .Row).Resize(1, 3).Font.Name = "Times New Roman"
            .Parent.Range("A" & .Row).Resize(1, 3).Font.Size = 12
            .Parent.Range("A" & .Row).Resize(1, 2).HorizontalAlignment = xlLeft
        End If
    End With
  
    'Formate Column A
    If Target.Column = 1 Then
        Dim s As String
        Dim arr As Variant

        s = Target.Value
        If s = "" Then
            Target.NumberFormat = "General"
        Else
            With CreateObject("vbscript.regexp")
                .Pattern = "[^0-9]"
                .Global = True
                .IgnoreCase = True
                arr = Split(Application.Trim(.Replace(s, " ")), " ")
            End With
            Target.Value = VBA.Join(arr, vbNullString)      ' <<<<<<<<< CHANGED
'           Target.NumberFormat = """REQ0000000""General"
        End If
    End If

    'Set Cell Movement within The Range
    'https://www.mrexcel.com/board/threads/set-movement-of-cells-in-dynamic-range-only.1172539/

    Dim rng As Range
    Set rng = Range("A1").CurrentRegion
    If rng.Rows.Count > 1 Then
        Set rng = Intersect(Target, rng.Offset(1, 0).Resize(rng.Rows.Count - 1, rng.Columns.Count))
    Else
        Set rng = Nothing
    End If
    If Not rng Is Nothing Then
        If Target.Column = 2 And Not (IsEmpty(Target)) Then
            Target.Offset(, 2).Select
        Else
            Target.Offset(, 1).Select
        End If
    End If

    Application.EnableEvents = True
End Sub


Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select

  If Target.Column <> 5 Or Application.CountA(Cells(Target.Row, 1).Resize(, 2)) < 2 Then Exit Sub
  Cancel = True
  Call Module3.SelectOLE3

End Sub


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select

  If g_blnWbkShtSelChange Then Exit Sub
  If Selection.Count = 1 Then
    If Not Intersect(Target, Range("C1")) Is Nothing Then
      g_blnWbkShtSelChange = True
      Call Module1.CheckSheet
    End If
  End If

End Sub

 

[GWteB]

keeps looping because the statement If Not c.ListObject Is Nothing is resulting False all the time since you are looping a single range Target.
You will never get out of the loop since the result is the same all the time

@Zot,
You are wrong with this comment. In case a Range object consists of a single cell, the Next statement in a For-Each construct doesn't branche back to the For statement, instead, the next line of code is been executed. In this particular case that would be the End Function line (so there has to be another cause of Vincent88's issue ...).

@Vincent88,
Within your previous thread (over here) you provided some code, in which some Workbook Events procedures were involved. Although you made your entire workbook available for download, I was unable to use it due to a potential security risk (see my comments on that in this post). I didn't examine your additional code provided with your response that thorough, and I replied:

Both the module 1 code and module 2 code of your post #8 don't have a conflict with the new separate functions whatsoever, they are not related in any way.

I should have said "not directly related", because the use of Event procedures should always be approached very carefully. Regarding your current issue, all of your code initial should work (with or without my additions), however ..., you've commented out some essential lines of code, causing the Workbook_SheetChange Event prodedure to be executed extremely repetitive. I would recommend to have a closer look at your BlankSheet procedure as of your post #1. At some point your are clearing the contents of all (!!) cells on a particular worksheet. Since you're using a sheet change event procedure with workbook scope, that event procedure is going to be executed over a 17 billion times, causing you the issue you currently have. When you let these lines participate again with your code, it's likely that your issue has been solved.

    'Clear All Contents
    Application.EnableEvents = False    ' <<<<<< TO BE INCLUDED  <<<<<<<<
                                        '        /\/\/\/\/\/\/\
    With ActiveSheet
      .Cells.ClearContents              ' <<< causing over 17 billion sheet change event calls, unless events are disabled
      With .OLEObjects                 
        .Visible = True
        .Delete
      End With
      With .Pictures
        .Visible = True
        .Delete
      End With
      .Range("A1").Resize(1, LastColumn).Value = ws.Range("A1").Resize(1, LastColumn).Value
      .ListObjects.Add(xlSrcRange, .Range("A1").Resize(2, LastColumn), , xlYes).Name = strSheetName
      .ListObjects(strSheetName).TableStyle = "TableStyleMedium2"
      .ListObjects(strSheetName).ShowAutoFilterDropDown = False
    End With
    
    Application.EnableEvents = True     ' <<<<<< TO BE INCLUDED  <<<<<<<<
    Set ws = Nothing                    '        /\/\/\/\/\/\/\

 

[Vincent88]

Hi GWteB,
This works now. Thanks a lot

 

[GWteB]

My pleasure, glad it's sorted.

 

[Zot]

Hi GWteB,
This works now. Thanks a lot

I was away for long time. Good to hear that @GWteB has the problem solved for you. I guess I misunderstood how your code work since I did not go through it thoroughly.