Below code hide a certain number of rows(depending on the number of the week we are in) and shows only the cell corresponding to the current week number and cells corresponding to the future week numbers.
Dim test As String
test = Format(Now, "yyyy", vbMonday) & KW(Now)
For k = 3 To lastColumn
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).ColumnWidth = cWidth
If ThisWorkbook.Worksheets(PlanningTableNameUG).Cells(1, k).Value = test Then
today = True
On Error Resume Next
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k - 1).Ungroup
On Error GoTo 0
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k - 1).Group
End If
If Not today Then
On Error Resume Next
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Ungroup
On Error GoTo 0
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Hidden = True
If Hidden = True Then
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group.Copy
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group.Insert Shift:=xlToRight
End If
Else
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Hidden = False
End If
Next k
' calculate the week number
Function KW(d As Date) As Integer
Dim Tag As Long
Tag = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
KW = (d - Tag - 3 + (Weekday(Tag) + 1) Mod 7) \ 7 + 1
End Function
Now, I need to count how many columns were hidden and add the exact numbers of columns, example:
columns:
1,2,3,4,5,6,7,8,9,10 (column 4 is corresponding to today week number)
I hide: 1,2,3 because there are in the past weeks, and want to add 11,12, 13, together with the week number corresponding for them, but not more than 1 year from current date.
Count of the weeks starts at the begging of the current year.
When hiding the columns you could add an integer variable that increases by one then use this variable to add that many new columns.
Then to add the week number, use the last column with the week number on it and add one to it for each of the new columns...
To count hidden columns in used range of ThisWorkbook.Worksheets(PlanningTableNameUG):
Dim col As Range
Dim cnt As Long
For Each col In ThisWorkbook.Worksheets(PlanningTableNameUG).UsedRange
Debug.Print col.EntireColumn.Hidden
cnt = cnt - col.EntireColumn.Hidden
Next col
EntireColumn.Hidden returns True if is hidden. True is -1 in VBA, that is why i deduct it from the counter to get positive value.
Related
Thanks to some wonderful people here on StackOverflow I have almost completed the code for my scheduling template generator! I just have three more things I would like to add that I am having some trouble with.
Current Breakdown: I have two sheets - "2 - Staff Listing" and "X - Template"
-The Values in in the staff listing sheet are a column of staff names beginning in Cell D9
-Then the Staff values are transferred to the template sheets starting in Cell B6
-There is a drop-down menu in the template sheet in Cell C2 where you can select which template you want to make just as an example it could read 5 Week or 5 Week with AM/PM
-Based on this Key I have it repeating each staff member's names X amount of times (5 in this case) and double that if AM/PM is selected so 10 times in this case
What I am hoping to still achieve:
-In the template sheet I would like column C to be the week number and column D to show AM/PM.
-So, for a 5 week AM/PM Template you would have Column C staring in cell C6 list Week 1, Week 1, Week 2, Week 2, up to Week 5. So, once for each week in the Key if it is AM/PM it should appear twice once for AM and once for PM.
-Then I would like it to list AM starting in cell D6 and then go PM and just keep repeating for the length of the names in column B. Additionally, if it is not an AM/PM template then I would like to hide column D.
Below is the code I currently have.
Sub populate_Template()
Worksheets("X - Template").Range("B6:K1000").ClearContents
Dim SourceData As Range
Set SourceData = Sheets("2 - Staff Listing").Range("D9")
Dim RepititionCell As Range
Set RepititionCell = Sheets("X - Template").Range("C2")
Dim Destination As Range
Set Destination = Sheets("X - Template").Range("B6")
Dim lr As Long
Dim arr As Variant
With SourceData.Parent
lr = .Cells(.Rows.count, SourceData.Column).End(xlUp).Row
arr = .Range(SourceData, .Cells(lr, SourceData.Column)).Value
End With
Dim repetition As Long
If Right(RepititionCell, 5) = "AM/PM" Then repetition = Split(RepititionCell.Value, " ")(0) * 2 Else repetition = Split(RepititionCell.Value, " ")(0)
Dim newarr() As String
ReDim newarr(1 To (lr - SourceData.Row + 1) * repetition, 1 To 1)
Dim count As Long
count = 0
Dim i As Long
For i = LBound(arr) To UBound(arr)
Dim y As Long
For y = 1 To repetition
count = count + 1
newarr(count, 1) = arr(i, 1)
Next y
Next i
Destination.Resize(UBound(newarr) - LBound(newarr) + 1).Value = newarr
End Sub
First you need to dim newarr to have three columns instead of one:
ReDim newarr(1 To (lr - SourceData.Row + 1) * repetition, 1 To 3)
Then your For y Next loop should fill in those other two columns. You can use the Mod operator to determine if you're on an odd or even row.
For y = 1 To repetition
Count = Count + 1
newarr(Count, 1) = arr(i, 1)
'if you're doubling up. You may want to put this in a Boolean variable
'to reduce code duplication
If Right(RepititionCell, 5) = "AM/PM" Then
'if it's an odd number
If y Mod 2 = 1 Then
newarr(Count, 2) = "Week " & (y + 1) / 2
newarr(Count, 3) = "AM"
Else 'even number
newarr(Count, 2) = "Week " & y / 2
newarr(Count, 3) = "PM"
End If
Else
'not doubling up, so y is the week number and nothing in column D
newarr(Count, 2) = "Week " & y
End If
Next y
Finally, you have to change your write line to account for the new columns
Destination.Resize(UBound(newarr, 1), UBound(newarr, 2)).Value = newarr
I got rid of the LBound part of the Resize because you're starting at 1 anyway. It's less robust if you happen to start your array at some other number. But between the likelihood that would happen and the improved readability, I think it's better.
this is my first VBA project and I'm stuck on one problem:
I need to calculate the monthly skewness using daily returns for multiple assets. First, I detected the months and the cells where each month ends and put them in a new worksheet. Based on that, I calculate the monthly skewness for each asset to get a table with the month in the rows and the assets in the columns.
The problem is that the skewness for the first and last row (so the first and last month) are incorrect, although the month is correctly identified by the first part of the code. In the second part of the code where I calculate the skewness I get this error: "Unable to get the Skew property of the WorksheetFunction class" for the line where I want to store the skew in an array but the skewness is calculated nonetheless. How can I solve the error message and get the correct skewness for the first and last month?
Any help would be very appreciated!
This is the code im working with:
Sub step1()
Dim v()
Dim idm()
Dim MonthCount As Single
'find the last row
lastrow = Worksheets("Data").Range("A2").End(xlDown).Row
'save the dates to array
v = Worksheets("Data").Range("A2:A" & lastrow).Value
'count the number of months
M = 1 'initiate month counter
For Row = 1 To lastrow - 2
'extract months from dates
month1 = month(v(Row, 1))
month2 = month(v(Row + 1, 1))
'increase the counter when the month changes
If month1 <> month2 Then
M = M + 1
End If
Next
MonthCount = M
'resize the month arrays
ReDim idm(1 To MonthCount, 1 To 2)
'detect change in month and save cumulative days as row indexes
M = 1 'initiate month counter
For Row = 1 To lastrow - 2
month1 = month(v(Row, 1))
month2 = month(v(Row + 1, 1))
If month1 <> month2 Then
'save the month
idm(M, 1) = month1 & "/" & Year(v(Row, 1))
'save the cumulative days
idm(M, 2) = Row + 1
M = M + 1
End If
On Error Resume Next
Next
'save the last month, cannot detect month change with empty row below
idm(M, 1) = month1 & "-" & Year(v(Row, 1))
idm(M, 2) = Row
'End With
'write the month array to excel
Worksheets("Months").Range("A2:B" & MonthCount + 1).Value = idm
End Sub
Sub step2()
Dim idMonth()
'save last month index to array
lastmonth = Worksheets("Months").Range("B2").End(xlDown).Row
idMonth() = Worksheets("Months").Range("B2:B" & lastmonth).Value
Dim z As Variant
Dim r1, r2 As Double
nc = Worksheets("Data").Range("A1").CurrentRegion.Columns.Count
'initiate counters
r1 = 2
r2 = 2
For c = 1 To nc
For M = 1 To UBound(idMonth) 'm is month index
'end of the month
r2 = idMonth(M, 1)
'set range for skewness
Set month_range = Worksheets("Data").Range(Cells(r1, c + 1).Address, Cells(r2, c + 1).Address)
'store skew in array
'error in the following line
z = Application.WorksheetFunction.skew(month_range)
'write skew to cells
Worksheets("Months").Cells(M + 1, c + 2).Value = z
'start of next month
r1 = r2 + 1
On Error Resume Next
Next
Next
End Sub
In Excel, I'd like a list of the 1st and 3rd Mondays in each month, for say the next six months after today.
Using a formula-based approach, I can find the 1st or 3rd Monday after today. I got stuck when trying to populate the list after that. Particularly, a challenge is to account for months with 5 Mondays in them. The formulas get very complex very quickly!
This is the solution I have so far:
Private Sub Auto_Open()
Dim i, mday As Integer
Dim row, col As Integer
Dim d As Date
Dim min As Integer
min = 14 'Minimum set up period
col = 1 'Column to put results in
row = 2 'Row to start from
d = Date + min + 9 - Weekday(Date) 'Find Monday after Minimum set up period
Worksheets("options").Activate
For i = 1 To 26 'Results up to 26 weeks in future
mday = day(d)
If (mday - 7 <= 0) Then 'First week
Cells(row, col).Value = d
row = row + 1
ElseIf (mday - 14 > 0 And mday - 21 <= 0) Then 'Third week
Cells(row, col).Value = d
row = row + 1
End If
d = d + 7 '+1 week
Next
Worksheets("New Starter").Activate
End Sub
Try this:
On A1 place the first day of one month. On A2 place: =EOMONTH(A1,0)+1
On B1 place =A1+MOD(8-WEEKDAY(A22,2),7).
On C1 place =B1+14
Drag an drop down.
The first column is taking the first day of one month and consecutive month, the column Bis returning the first monday and colunm C is returning the third monday of that month.
If you are looking for the 5th monday:
On D1 place: =IF(A1+MOD(8-WEEKDAY(A22,2),7)+28<EOMONTH(A1,0)+1,A1+MOD(8-WEEKDAY(A22,2),7)+28,"")
I have two excel sheets, one cumulative (year-to-date) and one periodic (quarterly). I am trying to check for potential entry errors.
Simplified ytd table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 12 20 28 10 20
2 5 11 18 26 10 20
3 5 11 18 26 10 20
Simplified quarterly table:
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 6 6 8 8 10 10
2 5 6 7 8 10 10
3 5 6 7 8 10 10
In the above example there are no entry errors.
I am trying to create a third sheet that would look something like this
ID Q1/18 Q2/18 Q3/18 Q4/18 Q1/19 Q2/19 ...
1 T T T T T
2 T T T T T
3 T T T T T
I initially tried using a formula like this:
=IF('YTD'!C2-'YTD LC'!B2-'QTR'!B2=0,T,F)
I don't particularly like this because the formula will not apply in the first quarter. This also assumes that my data in both sheets are ordered in the same way. Whilst I believe it to be true in all cases, I would rather have something like an index-match to confirm.
I tried working on a VBA solution based on other solutions I found here but made less progress than via the formulas:
Sub Compare()
lrow = Cells (Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xltoLeft).Column
Sheets.Add
ActiveSheet.Name = "Temp Sheet"
For i = 2 To lrow
For j = 3 To lcol
valytd = Worksheets("YTD").Cells(i,j).Value
valytd = Worksheets("YTD").Cells(i,j).Value
If valytd = valytd Then
Worksheets("Temp").Cells(i,j).Value = "T"
Else:
Worksheets("Temp").Cells(i,j).Value = "F"
Worksheets("Temp").Cells(i,j).Interior.Color Index = 40
End If
Next j
Next i
End Sub
In my opinion the easiest way is to:
Create a sheet & copy paste row 1 + Column 1 like image below (Title & IDs)
Use Sum Product to get your answers
Formula:
=IF(SUMPRODUCT((Sheet1!$B$1:$G$1=Sheet3!$B$1)*(Sheet1!$A$2:$A$4=Sheet3!A2)*(Sheet1!$B$2:$G$4))=SUMPRODUCT((Sheet2!$B$1:$G$1=Sheet3!$B$1)*(Sheet2!$A$2:$A$4=Sheet3!A2)*(Sheet2!$B$2:$G$4)),"T","F")
Formula Notes:
Keep fix the range with Quarters using double $$ -> Sheet1!$B$1:$G$1
keep fix the range with IDs using double $$ -> Sheet1!$A$2:$A$4
Keep fix the range with values -> Sheet1!$B$2:$G$
Keep fix column header -> =Sheet3!$B$1
Leave variable rows number -> =Sheet3!A2
Images:
This should do the trick, the code is all commented:
Option Explicit
Sub Compare()
Dim arrYTD As Variant, arrQuarterly As Variant, arrResult As Variant
Dim Compare As Scripting.Dictionary 'You need Microsoft Scripting Runtime for this to work
Dim i As Long, j As Integer, x As Integer
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.ScreenUpdating = False
End With
With ThisWorkbook
arrYTD = .Sheets("Name of YTD sheet").UsedRange.Value 'this will get everything on that sheet
arrQuarterly = .Sheets("Name of Quarterly sheet").UsedRange.Value 'this will get everything on that sheet
End With
ReDim arrResult(1 To UBound(arrYTD), 1 To UBound(arrYTD, 2)) 'resize the final array with the same size of YTD
Set Compare = New Scripting.Dictionary
'Here we fill the dictionary with the ID's position on the arrQuarterly array
For i = 2 To UBound(arrQuarterly) '2 because 1 is headers
If Not Compare.Exists(arrQuarterly(i, 1)) Then 'this is an error handle if you have duplicated ID's
Compare.Add arrQuarterly(i, 1), i 'now we know the position of that ID on the table
Else
'Your handle if there was a duplicated ID
End If
Next i
'Let's fill the headers on the result array
For i = 1 To UBound(arrYTD, 2)
arrResult(1, i) = arrYTD(1, i)
Next i
'Now let's compare both tables assuming the columns are the same on both tables (same position)
For i = 1 To UBound(arrYTD)
arrResult(i, 1) = arrYTD(i, 1) 'This is the ID
For j = 2 To UBound(arrYTD, 2)
x = Compare(arrYTD(i, 1)) 'this way we get the position on the quarterly array for that ID
If arrYTD(i, j) = arrQuarterly(x, j) Then 'compare if they have the same value on both sides
arrResult(i, j) = "T"
Else
arrResult(i, j) = "F"
End If
Next j
Next i
With ThisWorkbook.Sheets("Name of the result sheet") 'paste the array to it's sheet
.Range("A1", .Cells(UBound(arrResult), UBound(arrResult, 2))).Value = arrResult
End With
End Sub
What I am trying to achieve
I have two sheets: 'dashboard' and 'temp calc'.
Dashboard has all employee details and range "N1" "N2" contain dates.
Now a macro populates employee data and generates a daywise calendar as shown in the following image
'temp calc' has their project details with start date end date.(the date that do not fall between n1 and n2 dates from dashboard sheet are deleted here).
So now referencing their empid from dashboard sheet, and using the first day populated in dashboard sheet i loop through the emp id in temp calc sheet and return a count for the number of projects a employee is currently working on for the particular day. as shown in the following image.
how I achieve this:
the code.....
Option Explicit
Sub Count()
' x= no of columns(dashboard calender)
' y= no of rows(dashboard emp id)
' z= no of rows(temp calc sheet emp id)
Application.ScreenUpdating = False
'Clear calender data
Range("Q4").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
Dim i, j, k, l, d, x, y, z, Empid As Long
Dim currentdate, startdate, enddate As Date
x = (Range("n2") - Range("n1")) + 1
y = Application.WorksheetFunction.counta(Range("A:A")) - 1
z = Application.WorksheetFunction.counta(Worksheets("Temp Calc").Range("A:A")) - 1
For i = 1 To y Step 1 'To loop through the emp_id in dashboard.
For j = 1 To x Step 1 'To loop through the calender in dashboard daywise.
d = 0
For k = 1 To z Step 1 'To loop through the emp_id i temp calc sheet.
Empid = ActiveSheet.Cells(i + 3, 1).Value
currentdate = Cells(3, 16 + j).Value
startdate = Worksheets("Temp calc").Cells(k + 1, 3).Value
enddate = Worksheets("Temp calc").Cells(k + 1, 4).Value
If (Worksheets("Temp calc").Cells(k + 1, 1).Value) = Empid Then
If (currentdate >= startdate) And (currentdate <= enddate) Then 'To check whether the first column date falls within the project start and end date
d = d + 1
End If
End If
Next
Worksheets("Dashboard").Cells(i + 3, j + 16) = d
Next
Next
Range("q4").Select
Application.ScreenUpdating = True
End Sub
My problem: The code does the job,but I have two problems.
It is too slow
Sometimes the workbook will say not responding and won't do the work.I've checked it does not work in the background. I left the program running overnight and it went into not responding.
Possible solutions:
using two arrays: one array to store empid in dashboard,second array to store calendar generated in dashboard. and then compare it with data from temp calc sheet and return a count into array number 2 and write it back
the problem is I've just started reading about arrays and I am still learning
I am open to possible alternatives:
cheers,
mathew
There are several built in functions that will do this quite efficiently. There are just a couple I will list here:
Use Autofilter to select only a particular set of data (e.g. autofilter on an employee, or autofilter on date range etc) - then you can step through just the elements belonging to that employee
sort on employee - then you only step through valid employee IDs, and when you get to the next employee you start the next loop
use a pivot table to do the entire thing for you: create the table
with employee ID down the left side, date on top, and use "count" as the function being evaluated. You can use the Filter option in the pivot table to get this down to the date range you want - or you can autofilter the data in the employee table to the range you want before computing the pivot table
Any of these should make your code plenty fast - my personal preference is option 3... And if you don't like the layout of option 3, and you can't make it "just so", then create the pivot table in a hidden sheet and copy the data from there to the sheet you want.
As an aside - doing things like COUNTA("A:A" is likely quite slow since this means looking at all 1.5 million cells in the column. If the rows are contiguous you should be able to do something like:
COUNTA(RANGE("A1", [A1].End(xlDown)))
or (if not contiguous)
numRows = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
COUNTA(RANGE("A1", [A1].OFFSET(numRows,0)))
This works for me..... Hope it will be helpful for someone else with the same problem..
A big thank you to everyone who helped me with this and also for everybodys suggestions and answers.... :)
Sub assginment_count()
Dim a, i As Long, ii As Long, dic As Object, w, e, s
Dim StartDate As Date, EndDate As Date
Set dic = CreateObject("Scripting.Dictionary")
' use dic as a "mother dictionary" object to store unique "Employee" info.
dic.CompareMode = 1
' set compare mode to case-insensitive.
a = Sheets("temp calc").Cells(1).CurrentRegion.Value
' store whole data in "Temp Calc" to variable "a" to speed up the process.
For i = 2 To UBound(a, 1)
' commence loop from row 2.
If Not dic.exists(a(i, 1)) Then
Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
' set child dictionary to each unique "Emp Id"
End If
If Not dic(a(i, 1)).exists(a(i, 3)) Then
Set dic(a(i, 1))(a(i, 3)) = _
CreateObject("Scripting.Dictionary")
' set child child dictionary to each unique "Startdt" to unique "Emp Id"
End If
dic(a(i, 1))(a(i, 3))(a(i, 4)) = dic(a(i, 1))(a(i, 3))(a(i, 4)) + 1
' add 1(count) to a unique set of "Emp Id", "Startdt" and "Finishdt", so that it enables to count as
' different match even if multiple same unique set of "Emp Id", "Startdt" and "Finishdt" appears.
Next
With Sheets("dashboard")
StartDate = .[N1].Value: EndDate = .[N2].Value
With .Range("a3").CurrentRegion.Resize(, .Rows(3).Find("*", , , , xlByRows, xlPrevious).Column)
' finding the data range, cos you have blank column within the data range.
.Columns("q").Resize(.Rows.count - 3, .Columns.count - 16).Offset(3).Value = 0
' initialize the values in result range set to "0".
a = .Value
' store whole data range to an array "a"
For i = 4 To UBound(a, 1)
' commence loop from row 4.
If dic.exists(a(i, 1)) Then
' when mother dictionary finds "Employee"
For Each e In dic(a(i, 1))
' loop each "Startdt"
For Each s In dic(a(i, 1))(e)
' loop corresponding "Finishdt"
If (e <= EndDate) * (s >= StartDate) Then
' when "Startdt" <= EndDate and "Finishdt" >= StartDate
For ii = 17 To UBound(a, 2)
' commence loop from col.Q
If (a(3, ii) >= e) * (s >= a(3, ii)) Then
' when date in the list matches to date between "Startdt" and "Finishdt"
a(i, ii) = a(i, ii) + dic(a(i, 1))(e)(s)
' add its count to corresponding place in array "a"
End If
Next
End If
Next
Next
End If
Next
.Value = a
' dump whole data to a range.
End With
End With
End Sub