Agnarr
New Member
- Joined
- Jan 15, 2023
- Messages
- 28
- Office Version
- 365
- Platform
- 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:
Code for the whole month sheet creation:
and code for the creation of a specific day:
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 SubCode 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
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
