Check if sheetname exists before create

[Vincent88]

I run my code to duplicate a worksheet. If the worksheet is already existed , then no duplication of sheet and message box (Sheet (sheetname) does exists) will show. But this message box will also pop up when new sheet is created but I do not want this. I only want this msg box to pop up when I run the marco again and found the same sheetname already there. Please help.

Function DoesSheetExists(sh As String) As Boolean
    Dim ws As Worksheet

    On Error Resume Next
       Set ws = Sheets(sh)
    On Error GoTo 0

    If Not ws Is Nothing Then DoesSheetExists = True
End Function

Sub Check()
     Dim szToday As String
     szToday = Format(Date, "d mmm yyyy")
    

    If DoesSheetExists(szToday) Then
        MsgBox "Sheet " & szToday & " does exists"
     Else
         Call Module18.BlankSheet03
         MsgBox "Sheet" & szToday & " Created"
    End If
End Sub

 

[Vincent88]

Hi HaHoBe,
Error in Column A outside dynamic row. My intention is within the dynamic rows in column A, any inputs (like req%112233, 112233 will convert to REQ000000112233).

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

 

[HaHoBe]

Ji Vincent,

I just put the code from behind the worksheet and placed it into ThisWorkbook adjusting the name but I didn´t alter anything within the code. Could you explain "Column A outside dynamic row". Does that mean that the error occurs oiutside the table? Again, I´m working on a sample workbook which is more than rwo weeks old but no error shows up herer for me if I enter what you had mentioned.

Please make sure that there is either a procedure calling the transformation in ThisWorkbook or behind the worksheets.

Ciao,
Holger

 

[Vincent88]

Hi HaHoBe,
The function should only applicable to ColumnA row in column A, not whole column A.
The workable code is listed.
File also attached.
Please help.

'Formate Column A
Dim Lr As Long, s As String, arr As Variant
Lr = Range("A2").End(xlDown).Row
  If Intersect(Target, Range("A2:A" & Lr)) Is Nothing Then Exit Sub
   If Target.Count > 1 Then Exit Sub
   Application.EnableEvents = False
    s = Target.Value
If s = "" Then
    Target.NumberFormat = "Text"
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
   Application.EnableEvents = True
 End Sub

 

[HaHoBe]

Hi Vincent88,

in post #21 you attached an image displaying an error. In post #25 you present a different code (what you call "workable code") and ask for help. Could you please clarify first if the problem of #21 is solved?

Pasting just a part of what may be the code for a procedure will not make an answer easy as you would need to consider what is the most important issue with the event/procedure, what´s next and then locate the elements accordingly. From what I guess you would need to restrict the code to column A first as well as the UsedRange of the sheet from Row 2 to whatever column.

Ciao,
Holger

 

[Vincent88]

Hi HaHoBe,
I want to restrict the code to the continuious UsedRange in Column A, other cells in that column should be in normal NumberFormat = "General".
My code (FORMAT COLUMN A) is also not 100% work (for example - Suppose my last useful input is A5. If I enter any number(s) or alphabets in A8 or below, it will disrupt the functions of other columns when I go to input correct data in A6 - no dropdown list in column B, no sheetname( date) displays in column C, etc. )

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 > 3 Or Target.CountLarge > 1 Then Exit Sub
  If Target.Row = 1 Then Exit Sub
 
  Application.EnableEvents = False
  If Cells(Target.Row, "A") <> "" 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
  Else
      Cells(Target.Row, "C").ClearContents
      Cells(Target.Row, "D").ShrinkToFit = False
  End If
   Application.EnableEvents = True
 
'Formate Column A
   Dim Lr As Long, s As String, arr As Variant
   Lr = Range("A2").End(xlDown).Row
If Intersect(Target, Range("A2:A" & Lr)) Is Nothing Then Exit Sub
   If Target.Count > 1 Then Exit Sub
   Application.EnableEvents = False
    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
   Application.EnableEvents = True

End Sub

 

[HaHoBe]

Hi Vincent88,

you could restrict the area to work on for the end user via ScrollArea, meaning that when a new sheet is added only the header row and the first row of data is accessible. When entering data into say row the Change-Event wilkl set the ScrollArea to include a new row (here row 3). If you want to apply this to existing sheets as well you would need to use the Workbook_SheetActivate to limit the ScrollArea.

Let´s start with the copying of the sheet for a new date where you should add one line in procedure BlankSheet

...
      .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
      .ScrollArea = .Range(.Cells(1, 1), .Cells(2, LastColumn)).Address   'this is the line to limit access to 2 rows
...

Next is a small change in Workbook_SheetChange;

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

  Dim LastColumn As Long

  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select
 
  If Target.Column > 3 Or Target.CountLarge > 1 Then Exit Sub
  If Target.Row = 1 Then Exit Sub
  LastColumn = Sh.Range("A1").CurrentRegion.Columns.Count
  Sh.ScrollArea = Sh.Range(Sh.Cells(1, 1), Sh.Cells(Target.Row + 1, LastColumn)).Address
...

This will add a new row to the ScrollArea. Please test and come back to tell if more changes need to be taken.

Ciao,
Holger

 

[Vincent88]

wHi HaHoBe,
I think I found out the root cause. The issue seems on the code in formatting Column A. The code in BlankSheet to clear all contents does not really clear the formula from Row 3 downwards when copying from previous sheet. I tried to change
.Cells.ClearContents to .Cells.SpecialCells(xlCellTypeConstants, 23).ClearContents but not work.

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
    Application.DisplayAlerts = False
    
    ws.Copy before:=ActiveSheet
    strSheetName = Format(Date, "d mmm yyyy")
    ActiveSheet.Name = strSheetName
    'On Error GoTo 0
    Application.DisplayAlerts = True
  
 
    'Clear All Contents
    Application.EnableEvents = False
    With ActiveSheet
      .Cells.ClearContents
      With .OLEObjects
        If .Count > 0 Then
          .Visible = True
          .Delete
        End If
      End With
      With .Pictures
        If .Count > 0 Then
          .Visible = True
          .Delete
        End If
      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
      '.ScrollArea = .Range(.Cells(1, 1), .Cells(2, LastColumn)).Address   'this is the line to limit access to 2 rows
    End With
    
    Application.EnableEvents = True
    Set ws = Nothing
    g_blnWbkShtSelChange = False
    
  End If

End Sub

 

[HaHoBe]

Hi Vincent,

what about deleting the whole range from Row 3 to the last row?

...
    'Clear All Contents
    Application.EnableEvents = False
    With ActiveSheet
      .Cells.ClearContents
      .Range("A3", .Cells(Rows.Count, 1)).EntireRow.Delete
      With .OLEObjects
...

Ciao,
Holger

 

[HaHoBe]

Hi Vincent,

it may be a better place in the code if you insert the line after Buttons and OLEObjects were deleted.

Ciao,
Holger

 

[Vincent88]

Hi HaHoBe,
Yeah, delete those rows would be easier. Thanks.

How to change the condition of target value must have prefix "REQ000000" :
If Cells(Target.Row, "A").Value = "REQ000000" & "@_" And Cells(Target.Row, "B") <> "" Then

and I want the cursor move from row B to row D after selection of choice from dropdown list. I tried this code but in vain

'Move Cursor to Column D after Row B data selected
If Target.Column > 2 Then Exit Sub
If Target.Row = 1 Then Exit Sub
If Cells(Target.Row, "B") <> "" Then
If Selection.Count = 1 Then
Cells(ActiveCell.Row, "D").Activate
End If

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 
  Dim LastColumn As Long
 
  Select Case Sh.Name
    Case "Agents"
      Exit Sub
    Case Else
  End Select
 
  If Target.Column > 2 Or Target.CountLarge > 1 Then Exit Sub
  If Target.Row = 1 Then Exit Sub
  LastColumn = Sh.Range("A1").CurrentRegion.Columns.Count
  'Sh.ScrollArea = Sh.Range(Sh.Cells(1, 1), Sh.Cells(Target.Row + 1, LastColumn)).Address
 
  Application.EnableEvents = False
  If Cells(Target.Row, "A").Value = "REQ000000" & "@_" 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
  Else
        Cells(Target.Row, "C").ClearContents
        Cells(Target.Row, "D").ShrinkToFit = False
  End If
 
  Application.EnableEvents = True
 
'Formate Column A
Dim Lr As Long, s As String, arr As Variant
Lr = Range("A2").End(xlDown).Row
  If Intersect(Target, Range("A2:A" & Lr)) Is Nothing Then Exit Sub
   If Target.Count > 1 Then Exit Sub
   Application.EnableEvents = False
    s = Target.Value
If s = "" Then
    Target.NumberFormat = "General"
Else
     With CreateObject("vbscript.regexp")
     On Error GoTo 0
      .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

'Move Cursor to Column D after Row B data selected
    If Target.Column > 2 Then Exit Sub
    If Target.Row = 1 Then Exit Sub
    If Cells(Target.Row, "B") <> "" Then
    If Selection.Count = 1 Then
    Cells(ActiveCell.Row, "D").Activate
    End If
   End If
 
 
   Application.EnableEvents = True
  
End Sub