VBA problem with creating new sheets

Agnarr

New Member
Joined
Jan 15, 2023
Messages
28
Office Version
  1. 365
Platform
  1. Windows
Hello everyone!
I have made a sort of registry crm where one enters product code and quantity, excel returns name of product and price*quantity, plus it calculates start and end registry, loses, gains and other stuff.
Some macros that clear specific cells and 2 more macros that:
1. user enters a date in dd-mm-yyyy format and it creates as many new sheets as the month of the year entered all named after each day (01-02-2024), excluding all Sundays and all fixed non working days, and all are copy from the sheet named "Template".
2. a macro allowing to create a specific day (because sometimes maybe we're open in sundays for example) in a similar manner. User enters just the day (25) and the day is created after Template, named 25-02-2024 and put in the correct order (after 24th and before 26th).
It used to work great but then I needed to add an extra code which I made it just fine, but now the creation of new sheets is crashing the whole program. Please help me.
The following are the vba codes i've come up so far....
This is the main code for substitutions:
VBA Code:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    ' Disable events temporarily
    Application.EnableEvents = False
    
    ' Check if any cells in column H are changed
    If Not Intersect(Target, Sh.Range("H:H")) Is Nothing Then
        ' Check if the changed sheet is not a new sheet
        If Not IsNewSheet(Sh) Then
            Application.ScreenUpdating = False
        
            ' Loop through each cell in the changed range
            Dim cell As Range
            For Each cell In Intersect(Target, Sh.Range("H:H"))
                If cell.Value = "" Then
                    ' Clear cells B, C, D, E, and F
                    cell.Offset(0, -6).Resize(1, 6).ClearContents
                Else
                    Dim fnd As Range
                    Set fnd = Sheets("codes").Range("A:A").Find(cell.Value, LookIn:=xlValues, lookat:=xlWhole)

                    If Not fnd Is Nothing Then
                        ' Copying name and original price
                        cell.Offset(0, -6).Value = fnd.Offset(0, 1).Value
                        cell.Offset(0, -4).Value = fnd.Offset(0, 2).Value
                        cell.Offset(0, -1).Value = fnd.Offset(0, 3).Value
                        ' Calculating the price based on quantity
                        Dim quantity As Double
                        If IsEmpty(cell.Offset(0, -3).Value) Then
                            quantity = 1
                        Else
                            quantity = cell.Offset(0, -3).Value
                        End If
                        cell.Offset(0, -5).Value = cell.Offset(0, -4).Value * quantity
                    End If
                End If
            Next cell
            
            Application.ScreenUpdating = True
        End If
    End If
    
    ' Check if any cells in column G are changed
    If Not Intersect(Target, Sh.Range("G:G")) Is Nothing Then
        ' Check if the changed sheet is not a new sheet
        If Not IsNewSheet(Sh) Then
            Application.ScreenUpdating = False
        
            ' Loop through each cell in the changed range
            Dim cellG As Range
            For Each cellG In Intersect(Target, Sh.Range("G:G"))
                If cellG.Value = "" Then
                    cellG.Offset(0, -5).Resize(1, 7).ClearContents
                Else
                    Dim fndG As Range
                    Set fndG = Sheets("codes").Range("D:D").Find(cellG.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not fndG Is Nothing Then
                        ' Copying name and original price
                        cellG.Offset(0, -5).Value = fndG.Offset(0, -2).Value
                        cellG.Offset(0, -3).Value = fndG.Offset(0, -1).Value
                        cellG.Offset(0, 1).Value = fndG.Offset(0, -3).Value
                        ' Calculating the price based on quantity
                        Dim quantityG As Double
                        If IsEmpty(cellG.Offset(0, -2).Value) Then
                            quantityG = 1
                        Else
                            quantityG = cellG.Offset(0, -2).Value
                        End If
                        cellG.Offset(0, -4).Value = cellG.Offset(0, -3).Value * quantityG
                    End If
                End If
            Next cellG
            
            Application.ScreenUpdating = True
        End If
    End If
    
    ' Check if any cells in column E are changed
    If Not Intersect(Target, Sh.Range("E:E")) Is Nothing Then
        ' Check if the changed sheet is not a new sheet
        If Not IsNewSheet(Sh) Then
            Application.ScreenUpdating = False
        
            ' Loop through each cell in the changed range
            Dim rng As Range
            For Each rng In Intersect(Target, Sh.Range("E:E"))
                ' Get the corresponding row in column C
                Set cCell = Sh.Cells(rng.Row, "C")
                
                ' Recalculate the value in column C based on the formula in your sheet
                cCell.Value = Application.Evaluate("=IF(E" & rng.Row & "="""",D" & rng.Row & ",D" & rng.Row & "*E" & rng.Row & ")")
            Next rng
            
            Application.ScreenUpdating = True
        End If
    End If
    
    ' Re-enable events
    Application.EnableEvents = True
End Sub

Private Function IsNewSheet(sheet As Worksheet) As Boolean
    ' Check if the sheet's code name is "Sheet1" or "Sheet2" (default new sheet names)
    IsNewSheet = (sheet.CodeName = "Sheet1" Or sheet.CodeName = "Sheet2")
End Function

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Dim ws As Worksheet
    Set ws = Sh
    ' Disable events temporarily
    Application.EnableEvents = False
    ' Trigger the code for the new sheet
    Call Workbook_SheetChange(ws, ws.Cells(1, 1))
    ' Re-enable events
    Application.EnableEvents = True
End Sub
Private Sub Workbook_Open()
    ' Disable events temporarily
    Application.EnableEvents = False
    ' Call the SaveFile subroutine
    SaveFile
    ' Re-enable events
    Application.EnableEvents = True
End Sub

Sub SaveFile()
    ThisWorkbook.Save
    Application.OnTime Now + TimeValue("01:00:00"), "SaveFile"
End Sub

Code for the whole month sheet creation:
VBA Code:
Sub CreateSheets()
    Dim userInput As String
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim sheetName As String
    Dim templateSheet As Worksheet
    Dim newSheet As Worksheet
    Dim holidayDates As Variant
    Dim isHoliday As Boolean

    On Error GoTo ErrorHandler

    ' Prompt the user to enter a date
    userInput = InputBox("Enter a date in the format DD-MM-YYYY:", "Enter Date")
    
    If userInput = "" Then Exit Sub ' User canceled or entered nothing
    
    If Not IsDate(userInput) Then
        MsgBox "Invalid date format. Please enter a valid date.", vbExclamation
        Exit Sub
    End If
    
    startDate = CDate(userInput)
    
    If day(startDate) <> 1 Then
        MsgBox "Please enter the first day of the month.", vbExclamation
        Exit Sub
    End If
    
    ' Determine the end date of the month
    endDate = DateSerial(year(startDate), month(startDate) + 1, 0)
    
    ' Set the template sheet
    On Error Resume Next
    Set templateSheet = ThisWorkbook.Sheets("Template")
    On Error GoTo 0
    
    If templateSheet Is Nothing Then
        MsgBox "Template sheet not found. Please ensure there is a sheet named 'Template'.", vbCritical
        Exit Sub
    End If
    
    ' Define the array of holiday dates (MM-DD format)
    holidayDates = Array("01-01", "01-06", "03-25", "05-01", "08-26", "10-28", "12-25", "12-26") ' Add your holiday dates here
    
    ' Loop through each day of the month
    currentDate = startDate
    Do While currentDate <= endDate
        ' Check if the current date is not a Sunday or a holiday
        If Weekday(currentDate) <> vbSunday And Not IsInArray(Format(currentDate, "MM-DD"), holidayDates) Then
            MsgBox "Creating sheet for: " & Format(currentDate, "DD-MM-YYYY"), vbInformation
            
            ' Create a new sheet
            Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            If newSheet Is Nothing Then
                MsgBox "Error creating new sheet for " & Format(currentDate, "DD-MM-YYYY"), vbCritical
                Exit Sub
            End If
            sheetName = Format(currentDate, "DD-MM-YYYY")
            newSheet.Name = sheetName
            
            ' Copy contents from the template sheet
            MsgBox "Copying contents from the template sheet to the new sheet...", vbInformation
            templateSheet.Cells.Copy newSheet.Cells
            MsgBox "Contents copied successfully.", vbInformation
        End If
        ' Move to the next day
        currentDate = currentDate + 1
    Loop
    
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical
    Exit Sub
End Sub

Function IsInArray(valToBeFound As String, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If element = valToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function
and code for the creation of a specific day:
VBA Code:
Sub CreateSheetForSpecificday()
    Dim Template As Worksheet
    Dim newSheet As Worksheet
    Dim i As Integer
    Dim SelectedDay As Variant
    Dim CurrentYear As Integer
    Dim NewSheetName As String
    Dim newButton As Button
    Dim dayExists As Boolean
    Dim nextSheet As Worksheet
    Dim insertIndex As Integer
    Dim newSheetIndex As Integer

    ' Get the current year and month
    CurrentYear = year(Date)
    CurrentMonth = month(Date)

    Do
        ' Prompt user for the day
        SelectedDay = InputBox("Enter the specific day (e.g., 25 for 25th):", "Day Input")

        If SelectedDay <> "" Then
            ' Check if the input is a valid day
            If IsNumeric(SelectedDay) And Val(SelectedDay) > 0 And Val(SelectedDay) <= 31 Then
                ' Check if the entered day is within the current month
                If Val(SelectedDay) <= day(DateSerial(CurrentYear, CurrentMonth + 1, 0)) Then
                    NewSheetName = Format(Val(SelectedDay), "00") & "-" & Format(CurrentMonth, "00") & "-" & Right(Format(CurrentYear, "0000"), 4)
                    ' Check if sheet with the same name already exists
                    If Not SheetExists(NewSheetName) Then
                        ' Set Template Sheet
                        Set Template = ThisWorkbook.Sheets("Template")

                        ' Create new sheet
                        Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
                        newSheet.Name = NewSheetName

                        ' Copy everything from template
                        Template.Cells.Copy Destination:=newSheet.Cells

                        ' Set cell D4 with the specific day
                        newSheet.Cells(4, 4).Value = DateSerial(CurrentYear, CurrentMonth, Val(SelectedDay))

                        ' Create a new button in the new sheet
                        Set newButton = newSheet.Buttons.Add(Left:=newSheet.Cells(1, 1).Left, Top:=newSheet.Cells(1, 1).Top, Width:=10, Height:=10) ' Adjust size as needed
                        
                        ' Set the caption (text) of the button
                        newButton.Characters.Text = ""

                        ' Assign the macro to the button
                        newButton.OnAction = "ClearContentsTemplate"
                        
                        ' Find the index for insertion based on the sheet names
                        newSheetIndex = 1
                        For Each nextSheet In ThisWorkbook.Sheets
                            If IsDate(nextSheet.Name) Then
                                If CDate(nextSheet.Name) < CDate(NewSheetName) Then
                                    newSheetIndex = newSheetIndex + 1
                                Else
                                    Exit For
                                End If
                            End If
                        Next nextSheet
                        
                        ' Move the new sheet to the correct position
                        newSheet.Move Before:=Sheets(newSheetIndex)
                        
                        ' Exit the loop as the day is successfully added
                        Exit Do
                    Else
                        MsgBox "Sheet for the selected day already exists. Please choose another day."
                    End If
                Else
                    MsgBox "Entered day is outside the current month. Please choose a valid day."
                End If
            End If
        Else
            ' Exit the loop if the user cancels the input box
            Exit Do
        End If
    Loop
End Sub

Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(sheetName)
    On Error GoTo 0
    
    SheetExists = Not ws Is Nothing
End Function
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

Forum statistics

Threads
1,215,068
Messages
6,122,950
Members
449,095
Latest member
nmaske

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top