Related
I got problem with calendar in VBA. Wants to create a calendar that will show/paint the range of week numbers from 2022 depending on the date entered in columns A22 and B22. The problem occurs when the week numbers repeat between months.
Tydzien = Week
Sty = January
Lut = February
Option Explicit
Sub Kolorowaniedaty()
Dim rok As Integer
rok = Left(Cells(22, 2), 4)
Dim miesiacpocz As Integer
miesiacpocz = Mid(Cells(22, 2), 7, 1)
Dim miesiackon As Integer
miesiackon = Mid(Cells(22, 3), 7, 1)
Dim Datapocz As Integer
Datapocz = Application.WorksheetFunction.WeekNum(Cells(22, 2), 2)
Dim Datakon As Integer
Datakon = Application.WorksheetFunction.WeekNum(Cells(22, 3), 2)
Dim Rokzdaty As String
Rokzdaty = CStr(Mid(Cells(22, 2), 3, 2))
Dim Rok2022 As Byte
Rok2022 = 22
Dim kolumna As Byte
For kolumna = 1 To 20
If Rokzdaty = Rok2022 And miesiacpocz = miesiackon Then
Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 4)).Interior.Color = vbYellow
Else: Range(Cells(22, Datapocz + 4), Cells(22, Datakon + 5)).Interior.Color = vbYellow
End If
Next kolumna
End Sub
I cant upload image of Makro and Calendar from excel cuz i dont have enought points of reputations. If someone can help from private chat i will be really really thankful. Its must have from to my work.
[![enter image description here][3]][3]
Its Its suppose to mark 11 weeks but its show only 10 weeks. Any advice?
[3]: https://i.stack.imgur.com/X8kwQ.png
Iterate over each day in the date range and increment the column number each monday or change of month. Store the column numbers in an array and use it as a lookup to determine the column number for a given date. Run this is a new clean workbook.
update - complete rewrite
Option Explicit
Const START_COL = 4
Const START_ROW = 22
Const MAX_YEARS = 4
Const START_YEAR = 2022
Sub CalendarDemo()
Dim ws As Worksheet
Dim dt As Date, dtDay1 As Date
Dim wkno As Long, dayno As Long
Dim colno As Long, i As Long, c As Long, r As Long
Dim arCol, arDate
ReDim arCol(1 To 2, 1 To MAX_YEARS * 12 * 7)
ReDim arDate(1 To MAX_YEARS * 366, 1 To 5) ' wkno, month no, column, date, dow
' start Jan 1
dtDay1 = DateSerial(START_YEAR, 1, 1)
colno = 1
wkno = 1
i = 1
' iterate through days built look up array
dt = dtDay1
Do While Year(dt) < START_YEAR + MAX_YEARS
arDate(i, 2) = Month(dt)
arDate(i, 5) = Weekday(dt, vbMonday)
If i > 1 Then
' change of week or month
If arDate(i, 5) = 1 Then
wkno = wkno + 1
If (wkno > 52) And (Month(dt) = 1) Then wkno = 1
colno = colno + 1
ElseIf arDate(i, 2) <> arDate(i - 1, 2) Then
colno = colno + 1
End If
End If
' reset wkno to 1 on jan 1st
If wkno >= 52 And arDate(i, 2) = 1 Then wkno = 1
arDate(i, 1) = wkno
arDate(i, 3) = colno
arDate(i, 4) = dt
' fill arCol
arCol(1, colno) = Format(dt, "mmm yyyy")
arCol(2, colno) = wkno
dt = dt + 1
i = i + 1
Loop
' paint cells
Dim lastrow As Long, dtStart As Date, dtEnd As Date
Dim colStart As Long, colEnd As Long, n As Long, m As Long
Set ws = Sheets(1)
Call testdata(ws)
With ws
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For r = START_ROW To lastrow
' check dates are valid
dtStart = .Cells(r, "B")
dtEnd = .Cells(r, "C")
If dtEnd < dtStart Then
MsgBox "End Date before Start Date on row " & r, vbCritical
Exit Sub
ElseIf dtStart < dtDay1 Then
MsgBox "Start Date before 1 Jan " & START_YEAR & " on row " & r, vbCritical
Exit Sub
End If
' calc day number relative to day1
m = DateDiff("d", dtDay1, dtStart, dtDay1) + 1
n = DateDiff("d", dtDay1, dtEnd, dtDay1) + 1
If n > UBound(arDate) Or m > UBound(arDate) Then
MsgBox "Increase MAX_YEARS for row " & r, vbCritical
Exit Sub
End If
' lookup col number
colStart = arDate(m, 3) + START_COL
colEnd = arDate(n, 3) + START_COL
' merge and color
With .Cells(r, colStart)
With .Resize(1, colEnd - colStart + 1)
.Interior.Color = vbYellow
.Borders.LineStyle = xlContinuous
.Merge
End With
.Value = Space(5) & Format(dtStart, "dd mmm") & " - " & Format(dtEnd, "dd mmm yyyy")
End With
Next
End With
' add headers
Call FormatSheet(ws, arCol, arDate, colno)
MsgBox "Generated " & colno & " Columns", vbInformation
End Sub
Sub FormatSheet(ws As Worksheet, arCol, arDate, colno As Long)
Dim c As Long, i As Long, n As Long, dt As Date
' format sheet header rows
With Sheet1
.Rows("10:21").Clear
.Cells.MergeCells = False
With .Range("E20").Resize(2, colno)
.NumberFormat = "#"
.HorizontalAlignment = xlCenter
.Value2 = arCol
End With
' merge months
i = 0
For c = 5 To colno + 4
If .Cells(20, c + 1) = .Cells(20, c) Then
i = i + 1
Else
With .Cells(20, c - i)
Application.DisplayAlerts = False
.Resize(1, i + 1).Merge
Application.DisplayAlerts = True
.Resize(2, 1).Borders(xlLeft).LineStyle = xlContinuous
End With
i = 0
End If
Next
End With
' calendar to check array
For i = 1 To UBound(arDate)
dt = arDate(i, 4) ' date
n = arDate(i, 5) ' weekday
If dt > 0 Then
n = Weekday(dt, vbMonday)
ws.Cells(10 + n, arDate(i, 3) + START_COL) = Day(dt)
End If
' mon,tue,wed
If i < 8 Then
ws.Cells(10 + n, START_COL) = WeekdayName(n)
End If
Next
End Sub
Sub testdata(ws)
With ws
.Cells(22, 2) = "2022-01-01": .Cells(22, 3) = "2022-03-08"
.Cells(23, 2) = "2022-02-01": .Cells(23, 3) = "2022-02-28"
.Cells(24, 2) = "2022-03-01": .Cells(24, 3) = "2022-03-31"
.Cells(25, 2) = "2022-03-15": .Cells(25, 3) = "2022-05-15"
.Cells(26, 2) = "2022-03-15": .Cells(26, 3) = "2024-03-20"
End With
End Sub
I'm currently using 2 if loops and a do loop to get my result. But this is proving to be extremely slow and usually crashing. The file is around 16MB. Secondly, it is not correctly changing the start date in Sheet 1 for all dates i.e. sometimes if the date is less than the Startofweek. It will still give the initial date.
In sheet "Leasing". Column A contains Car numbers, Column E contains the Start Date and Column F contains the End Date.
Sheet 1 will be where the results are needed. Column A the start date, B the end Date and C the Car number.
I need it to give me the car number in Sheet 1:
i) If car number is not blank then
if the end date in Leasing is blank.
a) End date in Sheet 1 would be Endofweek(inputted by user)
b) Start date in Sheet 1would be Startofweek(inputted by user) or Start Date(Leasing). Whichever is greater.
if end date is less than Endofweek but greater than startofweek.
a) End date in Sheet 1 would be EndDate leasing
b) Start date in Sheet 1would be Startofweek(inputted by user) or Start Date(Leasing). Whichever is greater.
Column D of Sheet 1 then contains the difference between End of week and Start of week(Column B - Column A)
Example: Startofweek: 22/3/21, Endofweek: 28/3/21
'''
Sub active_leasing_cars()
Application.ScreenUpdating = False
Const Leasing_start = 5 'Column leasing start from Leasing Hisaab
Const Leasing_end = 6 'Column Leasing start from leasing Hisaab
Const Leasing_car = 1
Const TARGET = "Sheet1"
Const LEASING = "Leasing Hisaab"
Dim wb As Workbook, ws As Worksheet, wsResult, wsLeasing As Worksheet
Dim i, j, iLastrow As Integer
Dim Endofweek, Startofweek As String
Set wb = ThisWorkbook
Set wsResult = wb.Sheets(TARGET)
Set wsLeasing = wb.Sheets(LEASING)
iLastrow = wsLeasing.Cells(Rows.Count, Leasing_car).End(xlUp).Row
i = 1
j = 2
Endofweek = InputBox("Please enter end date", "Enter Date", Format(Date, "dd/mm/yyyy"))
Startofweek = InputBox("Please enter start date ", "Enter Date", Format(Date, "dd/mm/yyyy"))
Do
i = i + 1
If wsLeasing.Cells(i, Leasing_car) = "" Then
If wsLeasing.Cells(i, Leasing_end) = "" Then
wsResult.Cells(j, 2) = Endofweek
If wsLeasing.Cells(i, Leasing_start) <= Startofweek Then
wsResult.Cells(j, 1).Value = Startofweek
Else: wsResult.Cells(j, 1) = wsLeasing.Cells(i, Leasing_start)
End If
ElseIf wsLeasing.Cells(i, Leasing_end) >= Startofweek And wsLeasing.Cells(i, Leasing_end) <= Endofweek Then
wsResult.Cells(j, 2) = wsLeasing.Cells(i, Leasing_end)
If wsLeasing.Cells(i, Leasing_start) <= Startofweek Then
wsResult.Cells(j, 1) = Startofweek
Else: wsResult.Cells(j, 1) = wsLeasing.Cells(i, Leasing_start)
End If
End If
wsResult.Cells(j, 3) = wsLeasing.Cells(i, Leasing_car)
wsResult.Cells(j, 4) = DateDiff("d", wsResult.Cells(j, 1), wsResult.Cells(j, 2))
j = j + 1
End If
Loop While i < iLastrow
Application.ScreenUpdating = True
End Sub
That shouldn't take too long. You've no formulae in your worksheets do you?
You could disable display updates and the automatic calculations via the below at the start of your macro, and see how you go:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
(don't forget to reenable at the end)
If that doesn't help, then a bit more work is required - I'd advise loading your data into a 2D array though and going from there.
Dim leasingData()
iRows = 0
Do Until isEmpty(Sheets("Leasing").cell(2+iRows,1))
redim preserve leasingData(2, iRows)
leasingData(0, iRows) = Sheets("Leasing").Cells(2 + iRows, 1)
leasingData(1, iRows) = Sheets("Leasing").Cells(2 + iRows, 5)
leasingData(2, iRows) = Sheets("Leasing").Cells(2 + iRows, 6)
iRows = iRows = 1
Loop
Then from there, your searching and indexing should be much faster. The slowest part of VBA is interacting with the worksheets.
for iCar = 0 to ubound(leasingData,2)
if leasingData(2, iCar) = "" then
'No end date specified for this car, sub in end of week
end if
if leasingData(1, iCar) <= Start of week then
'The car leaase started before the start of this week, so update to start of week
end if
next iCar
etc etc
Then you can push the data out of the array onto your result sheet:
for iCar = 0 to ubound(leasingData,2)
Sheets("Target").cells(1+iCar, 3) = leasingData(0, iCar)
Sheets("Target").cells(1+iCar, 1) = leasingData(1, iCar)
Sheets("Target").cells(1+iCar, 2) = leasingData(2, iCar)
next iCar
In terms of your end of week update problem:
ElseIf wsLeasing.Cells(i, Leasing_end) >= Startofweek And wsLeasing.Cells(i, Leasing_end) <= Endofweek Then
wsResult.Cells(j, 2) = wsLeasing.Cells(i, Leasing_end)
Will never do what you want it to, you need to replace the RHS with Endofweek
You date comparison does not work properly because you have declared Startofweek As String. As a result wsLeasing.Cells(i, Leasing_start) <= StartOfWeek is False when the date 28/07/2020 is compared to the string 22/03/2021.
Option Explicit
Sub active_leasing_cars()
Const Leasing_start = 5 'Column leasing start from Leasing Hisaab
Const Leasing_end = 6 'Column Leasing start from leasing Hisaab
Const Leasing_car = 1
Const TARGET = "Sheet1"
Const LEASING = "Leasing Hisaab"
Dim wb As Workbook, ws As Worksheet, wsResult, wsLeasing As Worksheet
Dim i As Long, j As Long, iLastrow As Long
Dim EndOfWeek As Date, StartOfWeek As Date, s As String
Dim ar, t0 As Single: t0 = Timer
Set wb = ThisWorkbook
Set wsResult = wb.Sheets(TARGET)
Set wsLeasing = wb.Sheets(LEASING)
iLastrow = wsLeasing.Cells(Rows.Count, Leasing_car).End(xlUp).Row
' end of week
s = InputBox("Please enter end date dd/mm/yyyy", "Enter END Date", Format(Date, "dd/mm/yyyy"))
If IsDate(s) Then
ar = Split(s, "/")
EndOfWeek = DateSerial(ar(2), ar(1), ar(0))
Else
MsgBox s & " is not a date", vbCritical
Exit Sub
End If
' start of week
s = InputBox("Please enter START date ", "Enter Start Date dd/mm/yyyy", Format(EndOfWeek - 6, "dd/mm/yyyy"))
If IsDate(s) Then
ar = Split(s, "/")
StartOfWeek = DateSerial(ar(2), ar(1), ar(0))
Else
MsgBox s & " is not a date)", vbCritical
Exit Sub
End If
' sanity check
If StartOfWeek > EndOfWeek Then
MsgBox "Start: " & StartOfWeek & " after End: " & EndOfWeek, vbCritical
Exit Sub
End If
Dim sCar As String, dtStart As Date, dtEnd As Date, val As Variant
j = 1 ' sheet1 row
Application.ScreenUpdating = False
For i = 2 To iLastrow
sCar = wsLeasing.Cells(i, Leasing_car).Value
If Len(sCar) > 0 Then
' check start date
val = wsLeasing.Cells(i, Leasing_start).Value
If Len(val) > 0 Then
dtStart = val
Else
MsgBox "Start date is blank", vbCritical, "Row " & i
End If
' End Dates
val = wsLeasing.Cells(i, Leasing_end).Value
If Len(val) = 0 Then
'if the end date in Leasing is blank.
'a) End date in Sheet 1 would be Endofweek(inputted by user)
dtEnd = EndOfWeek
Else
dtEnd = val
End If
' filter for dates
If dtEnd < StartOfWeek Or dtStart > EndOfWeek Then
' ignore as either already ended or not started yet
Else
'b) Start date in Sheet 1 would be Startofweek(inputted by user)
' or Start Date(Leasing). Whichever is greater.
If dtStart > StartOfWeek Then
wsResult.Cells(j, 1) = dtStart
Else
wsResult.Cells(j, 1) = StartOfWeek
End If
wsResult.Cells(j, 2) = dtEnd
wsResult.Cells(j, 3) = sCar
wsResult.Cells(j, 4).FormulaR1C1 = "=RC[-2]-RC[-3]"
j = j + 1
End If
End If
Next
wsResult.Columns("B:C").NumberFormat = "dd/mm/yyyy"
Application.ScreenUpdating = True
MsgBox j - 1 & " records found for " & StartOfWeek & " to " & EndOfWeek, _
vbInformation, Int(Timer - t0) & " seconds"
End Sub
My code run perfectly but when it comes to add duration more than 24 hours, the code return time of next day. Please see image:
For instance:
CELL(C3)-0500_1145-DURATION IS 6.45
CELL(D3)-CTC-THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(E3)-0500_1145-DURATION IS 6.45
CELL(F3)-0500_1145-DURATION IS 6.45----TOTAL
DURATION=6.45(C3)+6.45(E3)+6.45(F3)=20.15
CELL(G3) & CELL(I3)-OFF -THE CODE WILL IGNORE AND MOVE TO NEXT CELL
CELL(H3)-1000_1800(ACP)-DURATION IS 8
Although the code calculate the duration right here i.e 8 hours but when the system sum all the duration it should give 28:15 but the system is taking it as next day and return total duration as 4:15.
My issue is that how can i make the system to return 28 hours 15 mins(28:15) iso of 4:15 when duration is more than 24 hours.
Sub CalculateHourly()
Dim j As Long
Dim TextTime, wStart, wStop, midnight As String
Dim TrueTime, Temp As Date
Dim Parts As Variant
Dim lRow As Long
Application.Calculation = xlManual
midnight = "24" & ":" & "00"
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And Not IsEmpty(TextTime) Then
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = Left(Parts(0), 2) & ":" & Right(Parts(0), 2)
'wStop = Left(Parts(1), 2) & ":" & Right(Parts(1), 2)
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2)
Debug.Print ("test : " & Format(wStart, "h:mm;#"))
'If timeout is less than timein
If wStart > wStop Then
'Add 24 hours and make the diff
TrueTime = 24 + CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
Else
'if timeout greater than timein
TrueTime = CDate(CDate(CDate(Format(wStop, "h:mm;#")) - CDate(Format(wStart, "h:mm;#"))))
End If
**If (Temp + TrueTime) > 24 Then
TrueTime = 24 + Temp + TrueTime**
Else
TrueTime = Temp + TrueTime
End If
Temp = TrueTime
End If
Next j 'move to the number column in the same row
Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
Temp = Temp - Temp
Next i 'move to the next row
End Sub
Use a function like this to format to hours:minutes only:
Public Function FormatHourMinute( _
ByVal datTime As Date, _
Optional ByVal strSeparator As String = ":") _
As String
' Returns count of days, hours and minutes of datTime
' converted to hours and minutes as a formatted string
' with an optional choice of time separator.
'
' Example:
' datTime: #10:03# + #20:01#
' returns: 30:04
'
' 2005-02-05. Cactus Data ApS, CPH.
Dim strHour As String
Dim strMinute As String
Dim strHourMinute As String
strHour = CStr(Fix(datTime) * 24 + Hour(datTime))
' Add leading zero to minute count when needed.
strMinute = Right("0" & CStr(Minute(datTime)), 2)
strHourMinute = strHour & strSeparator & strMinute
FormatHourMinute = strHourMinute
End Function
Sub CalculateHourly2()
Dim j As Long
Dim TextTime As String, wStart As Date, wStop As Date, midnight As String
Dim Parts As Variant
Dim lRow As Long
Dim vArray() As Variant, n As Integer
Application.Calculation = xlManual
'Find the last non-blank cell in column A(1)
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To lRow
n = 0
For j = 3 To 9
TextTime = ""
'copy content of the cells
TextTime = ThisWorkbook.Application.Sheets("Sheet1").Cells(i, j).Value
'loop only of cell does not contain any text
If InStr(1, TextTime, "CTC", vbTextCompare) = 0 And InStr(1, TextTime, "OFF", vbTextCompare) = 0 And InStr(1, TextTime, "LEAVE", vbTextCompare) = 0 _
And TextTime <> "" Then '<~~ Unlike the case where the cell is empty, if you put an empty cell into a variable, it is not empty.
Parts = Split(TextTime, "_")
'Left(Parts(0), 2) of 0430-04
'Right(Parts(0), 2) of 0430-30
wStart = TimeValue(Left(Parts(0), 2) & ":" & Right(Parts(0), 2))
'wStop = TimeValue(Left(Parts(1), 2) & ":" & Right(Parts(1), 2))
wStop = Left(Parts(1), 2) & ":" & Mid(Parts(1), 3, 2) '<~~ Since other characters have been added, the mid sentence must be used.
n = n + 2
ReDim Preserve vArray(1 To n)
vArray(n - 1) = wStart
vArray(n) = wStop
End If
Next j 'move to the number column in the same row
'Cells(i, 10).Value = CDate(Format(Temp, "h:mm;#"))
If n > 0 Then
Cells(i, 10).Value = getTime(vArray)
Cells(i, 10).NumberFormat = "[hh]:mm"
End If
Next i 'move to the next row
End Sub
Function getTime(Other() As Variant)
Dim myTime As Date, s As Date, e As Date
Dim i As Integer
For i = LBound(Other) To UBound(Other) Step 2
s = Other(i)
e = Other(i + 1)
If s > e Then
e = e + 1
End If
myTime = myTime + e - s
Next i
getTime = myTime
End Function
Sheet Image
The target is that I am making a small tool to be made in VBA Excel.
The task description is as follows:
1- Make a function in VBA code which would highlight the fixed holidays in the provided Calendar (New Year 01/01 , Labor Day 01/05 , Christmas Day 25/12 , Christmas Holiday 26/12)
2-Make a function in VBA code which would highlight the floating holidays in the provided Calendar (Easter Monday,Good Friday).
3-The worksheets in the workbook should be hyperlinked through the VBA code to a Business day ( Business days are from "Monday to Friday") , there is a condition here too. If the Business day in future calendar happen to be a Fixed Holiday or the Floating Holiday e.g There is New Year on a Tuesday so there would be a holiday observed, in such scenario the worksheet should not be available for this holiday date. In other words, the worksheets have tasks which are to be performed on Business Days only.So if there is a Holiday (irrespective of Fixed or Floating Holiday) the task worksheet containing the task information would not be available.
My issue is that I dont have much of knowledge in VBA.Through internet searches I have found the functions but how to integrate them to achieve the above?
My code and so far found stuff is following:
Public Sub Worksheet_Change(ByVal Target As Range)
Dim mth As Integer, b As Integer, dt As Integer, M As Integer, x As Integer, _
w As Integer, Y As Integer, Days As Integer, iRow As Integer
Dim dateDay1 As Date, dateLeapYear As Date, calYearCell As Range
Dim ws As Worksheet
Dim monthName(1 To 12) As String, weekDay(1 To 7) As String
On Error GoTo ResetApplication
'will enable events (worksheet change) on error
'check validity of worksheet name:
If Not ActiveSheet.Name = "Calendar" Then
MsgBox "Please name worksheet as 'Calendar' to continue"
Exit Sub
End If
Set ws = Worksheets("Calendar")
'address of cell/range which contains Calendar Year:
Set calYearCell = ws.Range("H7")
'At least one cell of Target is within the range - calYearCell:
If Not Application.Intersect(Target, calYearCell) Is Nothing Then
'turn off some Excel functionality so the code runs faster
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
If calYearCell = "" Then
MsgBox "Select Year to Generate Calendar"
GoTo ResetApplication
Exit Sub
End If
'clear first 7 columns and any previous calendar:
ws.Range("A:G").Clear
D = 0
'set names of 12 months for the array monthName:
monthName(1) = "January"
monthName(2) = "February"
monthName(3) = "March"
monthName(4) = "April"
monthName(5) = "May"
monthName(6) = "June"
monthName(7) = "July"
monthName(8) = "August"
monthName(9) = "September"
monthName(10) = "October"
monthName(11) = "November"
monthName(12) = "December"
'set names of 7 week days for the array weekDay:
weekDay(1) = "Monday"
weekDay(2) = "Tuesday"
weekDay(3) = "Wednesday"
weekDay(4) = "Thursday"
weekDay(5) = "Friday"
weekDay(6) = "Saturday"
weekDay(7) = "Sunday"
For mth = 1 To 12
'for each of the 12 months in a year
counter = 1
'determine day 1 for each month:
If mth = 1 Then
dateDay1 = "1/1/" & calYearCell
wkDay = Application.Text(dateDay1, "dddd")
If wkDay = "Monday" Then
firstDay = 1
ElseIf wkDay = "Tuesday" Then
firstDay = 2
ElseIf wkDay = "Wednesday" Then
firstDay = 3
ElseIf wkDay = "Thursday" Then
firstDay = 4
ElseIf wkDay = "Friday" Then
firstDay = 5
ElseIf wkDay = "Saturday" Then
firstDay = 6
ElseIf wkDay = "Sunday" Then
firstDay = 7
End If
Else
firstDay = firstDay
End If
'determine number of days in each month and the leap year:
dateLeapYear = "2/1/" & calYearCell
M = month(dateLeapYear)
Y = Year(dateLeapYear)
Days = DateSerial(Y, M + 1, 1) - DateSerial(Y, M, 1)
If mth = 1 Or mth = 3 Or mth = 5 Or mth = 7 Or mth = 8 Or mth = 10 Or mth = 12 Then
mthDays = 31
ElseIf mth = 2 Then
If Days = 28 Then
mthDays = 28
ElseIf Days = 29 Then
mthDays = 29
End If`Else
mthDays = 30
End If
`
'determine last used row:
If mth = 1 Then
iRow = 0
Else
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
End If
dt = 1
'maximum of 6 rows to accomodate all days of a month:
For i = 1 To 6
'7 columns for each week day of Monday to Sunday:
For b = 1 To 7
'enter name of the month:
ws.Cells(iRow + 1, 1) = monthName(mth)
ws.Cells(iRow + 1, 1).Font.Color = RGB(0, 0, 200)
ws.Cells(iRow + 1, 1).Font.Bold = True
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Interior.Color = RGB(191, 191, 191)
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
'enter week day (Monday, Tuesday, ...):
ws.Cells(iRow + 2, b) = weekDay(b)
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Font.Bold = True
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(0, 5000, 0)
ws.Range("F" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(5000, 0, 0)
'enter each date in a month:
If dt <= mthDays Then
'dates placement for the first row (for each month):
If firstDay > 1 And counter = 1 Then
For x = 1 To 8 - firstDay
ws.Cells(iRow + 2 + i, firstDay + x - 1) = x
Next x
dt = 9 - firstDay
'after placement of dates in the first-row for a month the counter value changes to 2, and then reverts
to 1 for the next month cycle:
counter = 2
w = 1
End If
'dates placement after the first row (for each month):
ws.Cells(iRow + 2 + i + w, b) = dt
dt = dt + 1
End If
Next b
Next i
w = 0
'determine placement of day 1 for each month after the first month:
firstDay = firstDay + mthDays Mod 7
If firstDay > 7 Then
firstDay = firstDay Mod 7
Else
firstDay = firstDay
End If
Next mth
'formatting:
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A" & iRow & ":G" & iRow).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
ws.Range("G1:G" & iRow).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
With ws.Range("A1:G" & iRow)
.Font.Name = "Arial"
.Font.Size = 9
.RowHeight = 12.75
.HorizontalAlignment = xlCenter
.ColumnWidth = 9
End With
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
ResetApplication:
Err.Clear
On Error GoTo 0
Application.EnableEvents = True
End Sub
' for floating holidays
Public Sub floatingholidays(NDow As Date, Y As Integer, M As Integer, _
N As Integer, DOW As Integer)
NDow = DateSerial(Y, M, (8 - weekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((N - 1) * 7))
End Sub
'for Easter date determination
Public Sub EasterDate(EasterDate2 As Date, Yr As Integer)
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
EasterDate2 = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - ((Yr + Yr \ 4 + _
D + (D > 48) + 1) Mod 7)
End Sub
You will not get a question like this answered here. You specify a large requirement and provide a large chunk of code that does not obviously relate to the requirement.
You must break this question into parts, attempt to solve those parts yourself.
For example:
Public Sub floatingholidays(NDow As Date, Y As Integer, M As Integer, _
N As Integer, DOW As Integer)
NDow = DateSerial(Y, M, (8 - weekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((N - 1) * 7))
End Sub
Add some comments to this sub-routine explaining what it does. When you return to this routine in 12 months, will you remember how it works?
Does this sub-routine set NDow to the correct value? Test it using macros like this:
Sub TestFH()
Call TestFHSub(2014, 1, 14, 5)
Call TestFHSub(2013, 1, 10, 1)
Call TestFHSub(2013, 2, 6, 2)
Call TestFHSub(2013, 5, 7, 3)
End Sub
Sub TestFHSub(ByVal Y As Integer, ByVal M As Integer, ByVal N As Integer, ByVal DOW As Integer)
Dim NDow As Date
Call floatingholidays(NDow, Y, M, N, DOW)
Debug.Print "If Y=" & Y & " M=" & M & " N=" & N & " DOW=" & DOW & " Then NDow=" & NDow
End Sub
I doubt the values I used in my calls of TestFHSub are sensible. Replace them with a good selection of values so you are convinced this routine works as required. If you need help ask a question about floatingholidays.
Do the same EasterDate.
Next think about how to call routine. Placing this code in a Worksheet_Change routine means it will be called every time you switch worksheet.
Discard the On Error code which just makes debugging more difficult. Consider adding it at the end of development if there is a need. There probably will not be a need.
Discard Application.DisplayAlerts = False etc. Do not worry about the speed of the macro until you have got the code working.
MonthName is a VBA function so you do not need the monthName array.
WeekdayName is a VBA function so you do not need the weekDay array.
Build your macro a few statements at a time and check they are having the effect you seek. If small block of code does not give the effect you seek, ask a question about it.
Good luck.
I am trying to write a macro in Excel which will allow me to automatically do groupings based on the number located in the first column. Here is the code.
Sub Makro1()
Dim maxRow As Integer
Dim row As Integer
Dim groupRow As Integer
Dim depth As Integer
Dim currentDepth As Integer
maxRow = Range("A65536").End(xlUp).row
For row = 1 To maxRow
depth = Cells(row, 1).Value
groupRow = row + 1
currentDepth = Cells(groupRow, 1).Value
If depth >= currentDepth Then
GoTo EndForLoop
End If
Do While currentDepth > depth And groupRow <= maxRow
groupRow = groupRow + 1
currentDepth = Cells(groupRow, 1).Value
Loop
Rows(row + 1 & ":" & groupRow - 1).Select
Selection.Rows.Group
EndForLoop:
Next row
End Sub
The first column in the Excel file looks like this:
1
2
2
3
3
4
4
4
4
5
5
5
6
6
6
6
5
6
6
6
7
8
8
9
10
9
10
10
8
7
7
8
6
5
4
3
2
1
2
When the macro reaches the depth 8 speaking of the groupings, I get error number 1004. It looks like the Excel does not allow me to create a depth greater than 8. Is there a workaround for this? I am using MS Excel 2003.
You are out of luck.
There is an 8 level limit for grouping which
also exists in xl07
on my testing exists in xl2010 (gives "Group method of range class failed")
I wrote this code to hide the sublevel rows, like grouping does.
it needs the first row empty, where the general level buttons will be placed.
it will create a button (placed in the first column) for each node with sublevels.
Clicking on the buttons will hide/unhide the corresponding sublevels.
the check_col is a colum that must be filled up to the last rows (i.e. no blank rows, or the "while" loop will stop
the lvl_col is the column that contains the level index
the start_row is the first row that contains useful data
hope this helps
Sub group_tree()
check_col = "A"
lvl_col = "D"
start_row = 3
Dim btn As Button
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Dim t As Range
'------------Place the buttons on top--------------
i = start_row
e_lvl = 0
b_spac = 0
b_width = 20
b_toggle = 0
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If lvl > e_lvl Then e_lvl = lvl
i = i + 1
Wend
Set t = ActiveSheet.Range("A" & 1)
For c = Range(lvl_col & start_row) To e_lvl
Set btn = ActiveSheet.Buttons.Add(t.Left + b_spac, t.Top, b_width, 10)
With btn
.OnAction = "btnS_t"
.Caption = c
.Name = start_row & "_" & c & "_" & lvl_col & "_" & b_toggle
End With
b_spac = b_spac + 20
Next
'--------------Place the buttons at level---------
i = start_row
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If Range(lvl_col & i + 1) > lvl Then
Set t = ActiveSheet.Range("A" & i)
' Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, b_width, 10)
With btn
.OnAction = "btnS"
.Caption = lvl
.Name = i & "_" & lvl & "_" & lvl_col
End With
End If
i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub btnS()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
' MsgBox (lvl_col)
Call hide_rows(start_lvl, start_row, lvl_col)
End Sub
Sub hide_rows(start_lvl, start_row, lvl_col)
a = start_row + 1
While Range(lvl_col & a) > start_lvl
a = a + 1
Wend
If Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False Then
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = True
Else
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False
End If
End Sub
Sub btnS_t()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
b_toggle = CInt(id(3))
If b_toggle = 0 Then
b_toggle = 1
Else
b_toggle = 0
End If
b.Name = start_row & "_" & start_lvl & "_" & lvl_col & "_" & b_toggle
Call hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
End Sub
Sub hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
a = start_row
While Range(lvl_col & a) <> ""
b = a
While Range(lvl_col & b) > start_lvl
b = b + 1
Wend
If b > a Then
If b_toggle = 1 Then
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = True
Else
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = False
End If
a = b - 1
End If
a = a + 1
Wend
End Sub