VBA: find second largest value - vba

I have the following problem: I try to filter a date column (A) in a worksheet (HISTORICALS) to return the highest and second highest date value. Currently, there is dates ranging from the 25th to the 31st of December in this column. Unfortunately, below formula (using the Large function) returns the 31st two times (and not the 30th and 31st as intended).
Sub Select_Last_Two_Days()
With Worksheets("HISTORICALS")
Highest_Max = Format(WorksheetFunction.Large(Worksheets("HISTORICALS").Range("A:A"), 1), "Short Date")
Second_Highest_Max = Format(WorksheetFunction.Large(Worksheets("HISTORICALS").Range("A:A"), 2), "Short Date")
Debug.Print Highest_Max, Second_Highest_Max
End With
End Sub
The column has approx. 2000 rows, with dates occuring multiple times. So ideally I would want to filter for distinct values and then return the two highest dates. Any idea how I can do that?

Simply translate Barry Houdinis answer from How to find the first and second maximum number? to VBA:
Sub Select_Last_Two_Days()
With Worksheets("HISTORICALS")
Highest_Max = Format(WorksheetFunction.Max(.Range("A:A")), "Short Date")
Second_Highest_Max = Format(WorksheetFunction.Large(.Range("A:A"), WorksheetFunction.CountIf(.Range("A:A"), WorksheetFunction.Max(.Range("A:A"))) + 1), "Short Date")
Debug.Print Highest_Max, Second_Highest_Max
End With
End Sub

The recommendations given in the comments are probably the simplest and least amount of code way to do things but here is another sugggestion:
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("HISTORICALS")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim loopArr()
loopArr = ws.Range("A1:A" & lastRow).Value
Dim maxVal As Date
maxVal = Application.WorksheetFunction.Large(ws.Range("A1:A" & lastRow), 1)
Dim i As Long
Dim secondVal As Date
For i = UBound(loopArr, 1) To LBound(loopArr, 1) Step -1
If loopArr(i, 1) < maxVal Then
secondVal = loopArr(i, 1)
Exit For
End If
Next i
End Sub

Related

Date Comparison Issue VBA

I am trying to compare Dates in a vba script. I believe the main issue is my formatting however I am not sure how to solve it.
Sub Rem9()
Dim i As Long
Dim lr As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
wsName = ws.Name
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
FirstDateRead = CDate("1, 1,2018") 'Initialize the first Day of the year as the last day
For i = 1 To lr
Debug.Print FirstDateRead
Debug.Print ws.Cells(i, 1).Value
If FirstDateRead > ws.Cells(i, 1).Value Then
ws.Cells(i, 3).Value = 121325
End If
Next i
End Sub
According to my output the First Date Read is never greater than the values I am pulling, Which it is for all cases. I have included here an example of the debug.print from the script I am running to show the date formats. Additionally I want to confirm the values I am drawing from are indeed datevaluse as when I run them through the IsDate() Function it returns True.
One other issue if that my date format for the value I call is swapping the year and day. Does anyone know how to solve that. When I use the format function it returns the date as.
Assuming the cells containing the dates are in text format, try wrapping the comparison value in a cDate:
If FirstDateRead > Cdate(ws.Cells(i, 1).Value) Then
ws.Cells(i, 3).Value = 121325
End If
Try using the DateDiff function instead:
Sub dateDifference()
Dim d1 As Date, d2 As Date
d1 = CDate("1, 2,2018")
d2 = Range("A1").Value ' insert a date in A1 to test
Debug.Print DateDiff("d", d1, d2) ' first parameter set to days
End Sub
Edit #1
Use Format to compare apples with apples, so to speak:
d2 = Format(Range("A1").Value, "dd/mm/yyyy")

Transforming month names to numbers

I have a userform that askes to which month the data input is applicable. I have used a combibox with jan, feb, mar etc as possible answers.
Now I want to use these answers to refer to a sheet index number Jan is sheets(2), feb = sheets(3) etc.
How do I do this?
Private Sub Userform_Initialize()
'Empty maandbox1
MultiPage1.Value = 0
Maandbox.Value = ""
With Maandbox
.AddItem "Jan"
.AddItem "Feb"
.AddItem "Mar"
'etc
End With
'Set Focus on Monthbox
Maandbox.SetFocus
End Sub
And then something like:
dim ws as worksheet
dim i as integer
i = Monthbox.Value
Set ws = ActiveWorkbook.Worksheets(i + 1)
i = Monthbox.Listindex + 2
should do the trick, since the listindex starts at 0.
You could use MonthName(). It takes a Long value and it returns its month. Thus, 1 is January, 2 is February and etc. To get the first three letters of the month use Left(value, 3):
Public Sub TestMe()
Dim cnt As Long
For cnt = 1 To 12
Debug.Print MonthName(cnt)
Debug.Print Left(MonthName(cnt), 3)
Next cnt
End Sub
In your case:
Dim ws As Worksheet
Dim i As Long
i = Monthbox.Value
Set ws = ActiveWorkbook.Worksheets(Left(MonthName(cnt + 1), 3))
You can use the DateValue function to return a dummy date and pull the integer month number from there:
Dim dt as Date, i as Long
dt = DateValue(Maandbox.Value & " 1," & Format(Now(),"YYYY"))
i = Format(dt, "M") + 1
I usually just set the date to the first of the month. The Format(Now(),"YYYY") simply turns the current day's date into a year to complete the DateValue function parameters. I have found this method flexible because it creates a date that you can now format however else you need it. For instance, if you need the full month description, you now have the option of doing:
RunMonth = Format(dt, "MMMM")
since it's been saved in your variable.

Sum row values based on start and date of a month in another column

Attaching image for better understanding of question:
Here, Column A has dates, B has daily amount and C has the cumulative sum of each days.
I want to stop the cumulative calculation at end of each month based on A column and start recalculating for next month. Just like shown in image.
I am using below code to find the end of month and on first day of month assigning B=C, But confused how can I start calculating cumulative amount from next day onward for that month.
Appreciate if someone provide me a logic to achieve this.
Sub MonthInt()
Dim MaxGain As Workbook
Dim DailyData As Worksheet
Dim n As Long, J As Long
Set MaxGain = Excel.Workbooks("MaxGain.xlsm")
Set DailyData = MaxGain.Worksheets("DailyData")
n = DailyData.Cells(Rows.Count, "A").End(xlUp).Row
DailyData.Range("B2") = DailyData.Range("C2")
For J = 3 To n
If DailyData.Range("A" & J) = Application.WorksheetFunction.EoMonth(DailyData.Range("A" & J), 0) Then
DailyData.Range("C" & J + 1) = DailyData.Range("B" & J)
End If
Next
End Sub
Why do you need VBA to get the desired output?
You may use the formulas to achieve the desired output.
Try this...
In C2
=B2
In C3
=IF(MONTH(A3)<>MONTH(A2),B3,C2+B3)
and copy it down.
Edit:
If you want to implement the formula through VBA, you may try something like this...
Sub MonthInt()
Dim MaxGain As Workbook
Dim DailyData As Worksheet
Dim n As Long
Set MaxGain = Excel.Workbooks("MaxGain.xlsm")
Set DailyData = MaxGain.Worksheets("DailyData")
n = DailyData.Cells(Rows.Count, "A").End(xlUp).Row
With DailyData
.Range("C2").Value = .Range("B2").Value
.Range("C3:C" & n).Formula = "=IF(MONTH(A3)<>MONTH(A2),B3,C2+B3)"
.Range("C3:C" & n).Value = .Range("C3:C" & n).Value
End With
End Sub

How to debug my simple Excel VBA macro?

I'm just trying to check the latest Date cell, which is in Column A, against the current date. If the difference is 30 days, I write a new row.
When I execute, it says I can't call CheckAttendance on Sheet("Occurences"). But why?
Option Explicit
Public LastCell As Long
Public today As Date
Function CheckAttendance()
Dim DaysSinceOcc As Integer
'returns last occupied row
LastCell = Cells(Rows.Count, 1).End(xlUp).Row
'gets current date
today = Date
'subtracts last cell in specified column from today's date.
DaysSinceOcc = today - Cells(LastCell, 1).Value
'writes what I want written in the cells I want it written in.
If DaysSinceOcc > 29 Then
Cells(LastCell, 1).Offset(1, 1) = "winback"
Cells(LastCell, 1).Offset(1, 2) = -0.5
Cells(LastCell, 1).Offset(1, 4) = "Earned back 0.5 pts for 30 days perfect attendance (AutoGenerated)"
Cells(LastCell, 1).Offset(1, 5) = "AUTO"
Cells(LastCell, 1).Offset(1, 0) = today
Else
End If
End Function
Sub Attendance()
Sheets("Occurences").CheckAttendance
'yes Occurences is suppose to be spelled like that (don't ask)
End Sub
edit: there are probably multiple problems with this. I fixed a lot of things, but then got stuck.
It seems that you want to parametrize your CheckAttendance routine so that it can be called on different worksheets. To do that, make it a Sub that takes a worksheet as parameter. Moreover
qualify you cells and ranges in the code
dim your variables and use Option Explicit
Option Explicit
Sub CheckAttendance(ws As Worksheet)
Dim DaysSinceOcc As Long, lastRow As Long, today As Long
lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).row
'gets current date
today = Date
'subtracts last cell in specified column from today's date.
DaysSinceOcc = today - ws.Cells(lastRow, 1).Value2
'writes what I want written in the cells I want it written in.
If DaysSinceOcc > 29 Then
ws.Cells(lastRow + 1, 1) = today
ws.Cells(lastRow + 1, 2) = "winback"
ws.Cells(lastRow + 1, 3) = -0.5
ws.Cells(lastRow + 1, 5) = "Earned back 0.5 pts for 30 days perfect attendance (AutoGenerated)"
ws.Cells(lastRow + 1, 6) = "AUTO"
End If
End Sub
Sub Attendance()
CheckAttendance Sheets("Occurences") ' <-- this is how you call it on any worksheet
End Sub

Hide rows based on the date

I am trying to keep the last 365 days visible in a micro tracking worksheet. As a new date gets inputted it would hide the first visible entry on the sheet so that only 365 cells are constantly displayed with the newest date at the bottom(ex Jan 15, 2015) and the oldest date at the top(Jan 15, 2014). When the user inputs Jan 16, 2015 it would hide Jan 15, 2014 so that the first entry is now Jan 16, 2014, and so on.
It has probably been about 15 years since I last used VBA but currently the code shown below will hide row 3 (where the first date and data is entered) but after that I can't get it to then hide row 4 once row 369 has text entered. Some insight into what I might be doing wrong would be greatly appreciated.
I would also assume that as this sheet became progressively larger it would start to slow down in opening or running smoothly so I would have to start fresh unless there is a way to make sure it always stays fast.
Dim i As Integer
Dim j As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
i = 3
j = 368
If Cells(j, j) = "" Then
Rows(i).Hidden = True
End If
i = i + 1
j = j + 1
End Sub
This is a completely different approach, but might suit you better in the long run.
Instead of hiding the rows to view what you are interested in. This approach uses two sheets.
Log Sheet: Contains all days
Report Sheet: Re-fills with only the last 365 days.
Setup Involved:
Set a second sheet up for your report, and give it the same headers as your Log Sheet.
Place the code provided in a module
If you want, you can add a workbook event so when the workbook opens, you can call this sub and have it update itself, or attach it to a hotkey or button.
This gives you plenty of room to create new formulas and charts to work over the set range of the report sheet. You can hide the Log Sheet.
Code:
Sub lastYearReportFill()
Dim lastRow As Long, lastCol As Long, lRow As Long, rRow As Long
Dim log As String, report As String
Dim today As Date, tempDate As Date
Dim daysTest As Long
log = "Log" 'Name your worksheets here
report = "Report"
today = Now
lastRow = Sheets(log).Range("A" & rows.count).End(xlUp).row
lastCol = Sheets(log).Cells(2, Columns.count).End(xlToLeft).column 'Using Header Row
For lRow = 3 To lastRow
tempDate = Sheets(log).Cells(lRow, 1)
daysTest = DateDiff("d", tempDate , today)
If daysTest = 365 Then
Exit For
End If
Next lRow
For rRow = 3 To 368
For lCol = 1 To lastCol
Sheets(report).Cells(rRow, lCol).Value = Sheets(log).Cells(lRow, lCol).Value
Next lCol
lRow = lRow + 1
Next rRow
End Sub
This should do the trick:
Sub HideRows()
Dim lngLastRow As Long
lngLastRow = Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
If lngLastRow < 365 Then End
Rows(lngLastRow - 365).Hidden = True
End Sub
This is assuming that:
you are working in a sheet named "Sheet1" (if not, change the name in line 3 of the code accordingly)
the dates are in column A and start in row 1 (even the hidden ones). If the dates are in a different column, then change the second number in the cells(1, 1) statement to the number of the row. And if the dates do not start in row 1, change the first number of the cells(1, 1) statement to the row number of the first date.
And if you want to keep the row for the day exactly one year ago (as in, keep 1-15-14 on 1-15-15), you may need to change 365 in line 5 of the code to 366. This code also assumes that all other rows besides the one that was visible yesterday but doesn't need to be today are already hidden.
If you are concerned with speed, use Range AutoFilter Method which I answered HERE.
Applying it to your case:
Private Sub UpdateVisibleDates(sh As Worksheet, drng As Range)
With sh
Dim latest As Date
latest = .Range("A:A").Find("*", .Range("A1"), , , , xlPrevious).Value2
.AutoFilterMode = False
drng.AutoFilter 1, ">" & (latest - 365), xlAnd, "<=" & latest, False
End With
End Sub
Then just call it in your Worksheet_Change Event.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
If Not Intersect(Target, Me.Range("A:A")) Is Nothing Then
Dim r As Range
Set r = Me.Range("A1:A" & Me.Range("A:A") _
.Find("*", Me.Range("A1"), , , , xlPrevious).Row)
UpdateVisibleDates Me, r
End If
forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox "Error: " & Err.Number & vbCrLf & _
Err.Description, vbExclamation
Resume forward
End Sub
This is considering you have a complete date in Column A and your input doesn't skip dates.
But regardless, it will still hide dates not within the 365 date difference of the last entered date. HTH.