Limit the prefix vba function to dynamic range

[Vincent88]

I want to limit below vba code to the column A in dynamic range ONLY. Right now if I enter something outside the range, it shows error and disrupts other functions in Workbook_SheetChange. I attach my file for easy ref. Please HELP ! HELP
File attached Excel file

'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 = arr
      Target.Value = Target.Value * 1
      Target.NumberFormat = """REQ0000000""General"
    End If

 

[GWteB]

Please provide all of your code in your sheet event procedure so we are able to help you ....

 

[Vincent88]

I thought if the file link work !
I attached the file again
Excel file
The link :

Test Create Today Sheet_Simple0630.xlsm

drive.google.com

'Excel file link : https://drive.google.com/file/d/13w-AbgY83g02qHGqBrHr_6N26UkNpWKr/view?usp=sharing


Private Sub Workbook_BeforeClose(Cancel As Boolean)
        Call Module1.DeleteCheck
End Sub

Private Sub Workbook_Open()
        Call Module1.CreateCheck
        'Application.MoveAfterReturnDirection = xlToRight
        'Application.MoveAfterReturn = True
            

End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
    
  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select
 
      
  If Target.Column > 4 Or Target.CountLarge > 1 Then Exit Sub
  If Target.Row = 1 Then Exit Sub

 
  Application.EnableEvents = False
 
  If InStr(1, Cells(Target.Row, "A"), "REQ") <> "" And Cells(Target.Row, "B") <> "" Then
 
        Cells(Target.Row, "C") = ActiveSheet.Name
        Cells(Target.Row, "C").Font.Name = "Times New Roman"
        Cells(Target.Row, "C").Font.Size = 12
        Cells(Target.Row, "C").HorizontalAlignment = xlRight
        Cells(Target.Row, "D").ShrinkToFit = True
        Cells(Target.Row, "A").Font.Name = "Times New Roman"
        Cells(Target.Row, "A").Font.Size = 12
        Cells(Target.Row, "A").HorizontalAlignment = xlLeft
        Cells(Target.Row, "B").Font.Name = "Times New Roman"
        Cells(Target.Row, "B").Font.Size = 12
        Cells(Target.Row, "B").HorizontalAlignment = xlLeft
      
   End If
 
 
'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 = arr
      Target.Value = Target.Value * 1
      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/
   If Target.CountLarge > 1 Then Exit Sub
 
  
    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]

It looks like you're multiplying a non-numeric value, causing you a type mismatch error. I have downloaded your workbook and will get back to you.

 

[Vincent88]

That's the point. I need help to modify the code to allow me to input any numerical or alphabetic value as usual if the active cell is not the continous row of the table.

 

[GWteB]

That's the point. I need help to modify the code to allow me to input any numerical or alphabetic value as usual if the active cell is not the continous row of the table.

I'm digesting your code at the moment but the above is really usefull information. Be patient ...

 

[GWteB]

My findings:
The error you got on this line:

    Target.Value = Target.Value * 1

occurred when the array variable arr contained no variables. In such a case the previous executed line of code:

    Target.Value = arr

didn't do anything, so the contents of range Target remained as per user input and could therefore hold non-numeric characters, causing the error in an attempt to multiply by one.

Changing it to

    Target.Value = VBA.Join(arr, vbNullString)

results in this case (due to the previously executed RegExp.Replace) always in a numeric value (0 or higher). A multiply by 1 will therefore succeed, although I'm not sure what benefit that would gain.

For the Case-Select-Case construct, used for checking on which worksheet the current change event procedure was triggered, I provide two alternatives. One for a single sheet and one in case multiple sheets should be excluded from being affected by this code. For the sake of readability of the code, the latter uses a custom function procedure (with a descriptive name: IsCurrentSheet), to be placed in a standard module.

The Instr function always returns a Long value, rather then a String. It would be best to take that into account in a comparison, to avoid unwanted / unexpected behaviour. Furthermore, it is recommended to avoid implicit assignments. For example, if two strings need to be compared, one of which comes from a cell, it is wise to (explicitly) use the .Text property to retrieve the contents of that cell, avoiding run-time errors under certain circumstances.

Finally, the provided IsPartOfListObject function procedure (also to be placed in a standard module) determines whether the range is all or part of a worksheet table, and returns TRUE or FALSE.

I hope this resolves your issue.


The separate functions:

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

The modified code:

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

    ' >> do not perform any action on sheet named Agents <<

    ' method 1: matches AGENTS agents Agents AgEnTs (and so on...)
    If StrComp(Sh.Name, "Agents", vbTextCompare) = 0 Then Exit Sub

'    ' method 2: for multiple sheets using a custum function within a standard module
'    '           sheetnames are expected in a string surrounded with slash characters
'    ' e.g.  "/Sheet1/sheet 2/MySheet/"

'    Const SHEETS_TO_EXCLUDE As String = "/Agents/Sheet5/AnotherSheet/"
'    If IsCurrentSheet(Sh, SHEETS_TO_EXCLUDE) 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

'OLD >> If InStr(1, Cells(Target.Row, "A"), "REQ") <> "" And Cells(Target.Row, "B") <> "" Then
        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
'OLD >>            Cells(Target.Row, "C").Font.Name = "Times New Roman"
'OLD >>            Cells(Target.Row, "C").Font.Size = 12
'OLD >>            Cells(Target.Row, "A").Font.Name = "Times New Roman"
'OLD >>            Cells(Target.Row, "A").Font.Size = 12
'OLD >>            Cells(Target.Row, "A").HorizontalAlignment = xlLeft
'OLD >>            Cells(Target.Row, "B").Font.Name = "Times New Roman"
'OLD >>            Cells(Target.Row, "B").Font.Size = 12
'OLD >>            Cells(Target.Row, "B").HorizontalAlignment = xlLeft
            .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.Value = Target.Value * 1                ' imo superfluous
            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

 

[Vincent88]

Hi GWteB,
Thank you for your valuable time to modify the codes. It seems the codes can rectify the error. However I cannot generate new sheet when run module 1 and may be not able to remove old sheets in module 2. It seems that both module 1 and 2 have conflict to the new separate functions you add. Please help to look into them for me.

Meantime you mentioned when using the Instr function better to use text property for comparison. Is there any difference if using value instead !

Module1

Global g_blnWbkShtSelChange As Boolean
'

Sub CreateCheck()
  Application.OnKey "^{BS}", "CheckSheet"

End Sub
Sub DeleteCheck()
  Application.OnKey "^{BS}"

End Sub


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


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


Module2


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

 

[GWteB]

It seems the codes can rectify the error.

It sure does, provided all the code is pasted into the right code modules.

However I cannot generate new sheet when run module 1 and may be not able to remove old sheets in module 2. It seems that both module 1 and 2 have conflict to the new separate functions you add.

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.
If you have issues with other (existing) code within your workbook, my code is not responsible for that. Also, since it's a completely different issue than your original request, I think it's reasonable asking you to start a new thread for this.
In addition to that, although I downloaded your file I couldn't get started with it and alternatively copied the code from this thread. Opening your workbook in protected mode it turned out to contain two hidden references which could be a threat to my computer (see attached immage), so I had to discard your workbook and limited myself to your provided code and screenshots as of your post #3.

Meantime you mentioned when using the Instr function better to use text property for comparison. Is there any difference if using value instead !

Yes, there's a difference between using .Text and using .Value, but the example I gave was perhaps a not very useful example (and btw it wasn't related to the Instr function, you really should read that sentence again...). I tried to point out that always relying on the default property of an object (by omitting a property's name in stead of explicitly writing a property's name, e.g. Cell(1,1) in stead of Cell(1,1).Value which is preferred) may be the cause of unexpected behaviour. Sometimes VBA gets "confused" and doesn't deliver the contents of the default property.

 

[Vincent88]

Hi GWteB,
Got you points. Thank you for your kind tutorial.
I will open another thread as suggested.