I am encountering a bug in VBA. As I am just a few weeks in, the code itself probably lacks a lot of best practices.
But besides that, in this specific case I get an Overflow error on the following line
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday) in the section
'========================
'make cell BLUE
'========================
The full code is listed below. Does anybody have an idea, what is causing this issue? As a greenhorn my guess is, this has to do with constantly reassigning 3 variables in the loop?
Thanks a lot in advance.
Sub HrReporting_Step07_ApplyCellColouring()
ThisWorkbook.Activate
'========================
'Variables for looping
'========================
'declarations
Dim rowCount As Integer
Dim i As Integer
Dim srcColourColumnIntRed1 As Integer
Dim srcColourColumnIntRed2 As Integer
Dim srcColourColumnIntYellow As Integer
Dim srcColourColumnIntGreen As Integer
Dim srcColourColumnIntBlue1 As Integer
Dim srcColourColumnIntBlue2 As Integer
'variable declaration specifically for date calculations that are needed for colouring cells YELLOW or BLUE
Dim olderDate As Date
Dim currentDate As Date
Dim dateDifference As Integer
'assignments
srcColourColumnIntRed1 = Range("Table1[Availability Status]").Column
srcColourColumnIntRed2 = Range("Table1[Sum of Current Calendar % Allocated]").Column
srcColourColumnIntYellow = Range("Table1[Coming Available Category]").Column
srcColourColumnIntGreen = Range("Table1[CW-1]").Column
srcColourColumnIntBlue1 = Range("Table1[Current Calendar]").Column
srcColourColumnIntBlue2 = Range("Table1[Current Calendar End Date]").Column
rowCount = Range("Table1[Coming Available Category]").Count + 1
'========================
'make cell RED
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Sum of Current Calendar % Allocated" is lower or equal to 60 %
' 2. Column "Availability Status" = Now Available
If Cells(i, srcColourColumnIntRed1).Value = "Now Available" _
Or Cells(i, srcColourColumnIntRed2).Value <= 60 _
Then Cells(i, 1).Interior.Color = RGB(255, 0, 0)
Next i
'========================
'make cell YELLOW
'========================
For i = 2 To rowCount
'based on following condition
' 1. Column "Coming Available Category" = Available in the next 2 weeks
If Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 1-7 Days" _
Or Cells(i, srcColourColumnIntYellow).Value = "Resource First Available Day 8-14 Days" _
Then Cells(i, 1).Interior.Color = RGB(255, 255, 0)
Next i
'========================
'make cell BLUE
'========================
For i = 2 To rowCount
'based on following conditions
' 1. Column "Current Calendar" unequal to "Booked To A Project"
' 2. Column "Current Calendar" unequal to empty
' 3. Column "Current Calendar End Date" < to 42 days AND > 12 days
olderDate = Cells(i, Range("Table1[Current Calendar End Date]").Column)
currentDate = Date
dateDifference = DateDiff("d", currentDate, olderDate, vbMonday)
If (Cells(i, srcColourColumnIntBlue1).Value <> "Booked To A Project" _
And Cells(i, srcColourColumnIntBlue1).Value <> "") _
Or (dateDifference <= 42 And dateDifference > 14) _
Then Cells(i, 1).Interior.Color = RGB(0, 0, 255)
Next i
'========================
'make cell GREEN
'========================
For i = 2 To rowCount
'based on following condition
' 1. Name does not exist in previous weeks' sheet, identified by VLOOKUP being #N/A
If WorksheetFunction.IsNA(Cells(i, srcColourColumnIntGreen)) _
Then Cells(i, 1).Interior.Color = RGB(0, 255, 0)
Next i
End Sub
It turned out that the comments from BigBen and Ron Rosenfeld solved my issue. I needed to simply declare dateDifference as Long, and the Overflow error was gone. Thank you.
Related
I have a problem I hope I can get some help with. In a summary report I need to use date criterias: today's date compared to months in B1:M1 (all cells are date formatted using a userdefined date format to only display the monthname) to sum the rows of data only if an account number is listed in column A. (pls. see below example)
I.E. if todays date is Feb. 7th the VBA code should loop through all rows and only sum the numbers for January and february where an account # is present (it must be in VBA)
Here is what I have so far:
Sub Test()
Dim today, lastdayinmonth As Date
Dim i, ii As Integer
Dim months As Range
today = DateSerial(Year(Date), Month(Date), Day(Date))
lastdayinmonth = DateSerial(Year(Date), Month(Date) + 1, 0)
months = Sheet2.Range("B2:M2")
If idag <= lastdayinmonth Then
For i = 3 To 20
If Not IsEmpty(Sheet2.Range("B" & i)) Then
End If
Next ii
End If
End Sub
Try this code, please. It works based on the assumption that your columns header are Date formatted (no matter if they show only month...), and the sum will be returned in Imediate Window:
Sub TestSumMonth()
Dim arrM As Variant, i As Long, j As Long
Dim nSum As Long, lastRow As Long, sh As Worksheet
Set sh = sheet2
lastRow = sh.Range("A" & sh.Rows.count).End(xlUp).Row
arrM = sh.Range("A1:M" & lastRow).Value
sh.Range("O2:O" & lastRow).Interior.ColorIndex = xlNone ' clear the existing interior color
For i = 1 To UBound(arrM, 1)
If arrM(i, 1) <> Empty Then
nSum = 0
For j = 2 To UBound(arrM, 2)
If Month(Date) >= Month(arrM(1, j)) Then
nSum = nSum + arrM(i, j)
If Month(Date) = Month(arrM(1, j)) Then
With sh.Range("O" & i)
.Value = nSum
.Interior.Color = vbYellow ' interior colored in yellow
End With
Exit For
End If
End If
Next j
End If
Next i
End Sub
The code firstly clears "O:O" range interior color, then returns the sum on the appropriate row of this column and colors the cell interior in yellow...
Now, it would summarize all the passed month values plus the active month.
I would like to create a simple button with a macro.
I have three Sheets in my excel file:
"VLS", "DTMS"and "Results"
I would like a macro which highlights the cells in column A in 'Results' if they appear in column A in VLS or DTMS respectively.
Is it possible to highlight the cells appearing in VLS with green and DTMS with blue?
Does this code help you?
Sub test()
Dim LastRowSheet1 As Integer
Dim LastRowSheet2 As Integer
Dim LastRowSheet3 As Integer
LastRowSheet1 = Sheets("Results").Cells(1, 1).End(xlDown).Row
LastRowSheet2 = Sheets("VLS").Cells(1, 1).End(xlDown).Row
LastRowSheet3 = Sheets("DTMS").Cells(1, 1).End(xlDown).Row
Dim Found As Boolean
Found = False
For i = 1 To LastRowSheet1
For j = 1 To LastRowSheet2
If Sheets("Results").Cells(i, 1).Value = Sheets("VLS").Cells(j, 1).Value Then
Sheets("Results").Cells(i, 1).Interior.Color = RGB(0, 255, 0)
'''Value found in sheet VLS => GREEN'''
Found = True
Exit For
End If
Next j
For k = 1 To LastRowSheet3
If Sheets("Results").Cells(i, 1).Value = Sheets("DTMS").Cells(k, 1).Value Then
If Found = True Then
Sheets("Results").Cells(i, 1).Interior.Color = RGB(255, 0, 0)
'''Value found in sheet VLS and DTMS => RED'''
Else
Sheets("Results").Cells(i, 1).Interior.Color = RGB(0, 0, 255)
'''Value found in sheet DTMS => BLUE'''
End If
Exit For
End If
Next k
Found = False
Next i
End Sub
It loops through your sheet "Results" column A and check all the values of the two others sheets : first with the sheet VLS then with DTMS.
As soon as the same value is detected in VLS, it changes the color to GREEN. Then if the value is also in DTMS, it changes the color to RED or if it's only in DTMS it changes it in BLUE.
If it works, you can create a button and then affect this macro to it.
I have the following issue with this VBA:
Column A (FirstDate), Column B (EndDate), Column C (Number) are input:
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Cells(lRow, 4).Value = i - 1
Next
End With
End Sub
If I run the above for 9 rows I got this, the output is the highlighted column:
All good so far, but if I try to run the code for more than 9 rows:
I got this:
I have searched for the answer on here I read in some posts that I'm not "calling the function in the right way" but I don't understand what do I need to change also I read that I need to check the permitted ranges for arguments to make sure no arrangement exceeds the permitted values.
How about the following using DateDiff:
Sub DateTest()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Dim IntervalType As String
Dim lLastRow As Long, lRow As Long
IntervalType = "m" ' "m" specifies MONTHS as interval.
lLastRow = ws.UsedRange.Rows.Count
For lRow = 1 To lLastRow
' If the number is not greater than zero an infinite loop will happen.
If ws.Cells(lRow, 3).Value <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
ws.Cells(lRow, 4).Value = DateDiff(IntervalType, ws.Cells(lRow, 1).Value, ws.Cells(lRow, 2).Value) / ws.Cells(lRow, 3).Value
Next lRow
End Sub
Change Debug.Print i to Debug.Print i & " - " & TempDate and see your Immediate Window. You will notice that for row 11 (31/08/2010 - 31/08/2020) the code is shifting the day from 31st (31st of August) to 30th (30th of November) and then defaults to 28th (28th of February). Once it reaches this stage, it will always take 28th day into account, making it impossible for the loop to finish the calculation (infinite loop).
The result will look like that:
2 - 30/11/2010
3 - 28/02/2011
4 - 28/05/2011
...
39 - 28/02/2020
40 - 28/05/2020
41 - 28/08/2020
42 - 28/11/2020
...
89 - 28/08/2032
90 - 28/11/2032
91 - 28/02/2033
...
I hope it clarifies the issue well enough and it gives you a hint on how to proceed.
I have a macro that does the following:
SETUP:
Compares a ID# between the "April Count" and "Prg-Srv Data" and turns the ones that are in common to a green cell background.
Filters the common data (anything with a green cell background) and copies that to a new worksheet "Medicaid Report". Then clears the AutoFilter and and formats the worksheet to specified style.
Filters and removes any rows that contain the word "Duplicate".
Finally it compares the April Count to the Medicaid Report to see if anyone has been missed from the April Count list.
PROBLEM IS THIS:
When the macro is finished it is still "randomly" marking data in the April Count that is also in the Medicaid Report and I'm not sure what I have done wrong.
Also if there is a more efficient way to do this let me know, this macro takes a long time to run and I'm not sure if its just because it has to do 5,000+ records or if I coded inefficiently. Thanks
CODE:
Sub ComparePrgSrv()
'Get the last row
Dim Report As Worksheet
Dim Report2 As Worksheet
Dim Report3 As Worksheet
Dim i, j, k As Integer
Dim LastRow, LastRow2, LastRow3 As Integer
Dim UniqueVal As New Collection
Dim Val As String
Set Report = Excel.Worksheets("April Count")
Set Report2 = Excel.Worksheets("Prg-Srv Data")
Set Report3 = Excel.Worksheets("Medicaid Report")
LastRow = Report.UsedRange.Rows.count
LastRow2 = Report2.UsedRange.Rows.count
LastRow3 = Report3.UsedRange.Rows.count
Application.ScreenUpdating = False
'April Count to Program Services comparison.
For i = 2 To LastRow2
For j = 2 To LastRow
If Report2.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, Report.Cells(j, 1).Value, Report2.Cells(i, 1).Value, vbTextCompare) > 0 Then
Report2.Cells(i, 1).Interior.Color = RGB(0, 102, 51) 'Dark green background
Report2.Cells(i, 1).Font.Color = RGB(0, 204, 102) 'Light green font color
Exit For
Else
Report2.Cells(i, 1).Interior.Color = xlNone 'Transparent background
Report2.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
End If
End If
Next j
Next i
'Filter Program Services to show correct data.
Report2.Range("$A$1:$M$" & LastRow2).AutoFilter Field:=1, Criteria1:=RGB(0, 102, 51), Operator:=xlFilterCellColor
'Copy filtered data to new worksheet.
Report2.Range("$A$1:$M$" & LastRow2).SpecialCells(xlCellTypeVisible).Copy Destination:=Worksheets("Medicaid Report").Range("A1")
'Clear filter selection on both sheets.
Report.AutoFilterMode = False
Report2.AutoFilterMode = False
'Format cell colors on Medicaid sheet.
Report3.UsedRange.Interior.Color = xlNone 'Transparent background
Report3.UsedRange.Font.Color = RGB(0, 0, 0) 'Black font color
Report3.Range("$A$1:$M$1").Interior.Color = RGB(31, 73, 125) 'Blue background
Report3.Range("$A$1:$M$1").Font.Color = RGB(255, 255, 255) 'White font color
'Filter and Delete Rows Containing "DUPLICATE"
With ActiveSheet
.AutoFilterMode = False
With Range("B1", Range("B" & Rows.count).End(xlUp))
.AutoFilter 1, "*DUPLICATE*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
'April Count to Medicaid Report comparison.
For i = 2 To LastRow
For j = 2 To LastRow3
If Report.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, Report3.Cells(j, 1).Value, Report.Cells(i, 1).Value, vbTextCompare) > 0 Then
Report.Cells(i, 1).Interior.Color = xlNone 'Transparent background
Report.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
End Sub
Workbook Setup:
First off, what do you mean by
"When the macro is finished "
For the effectiveness part:
You should remove the If Report2.Cells(i, 1).Value <> "" Then as it is already taken in account with the InStr. If cell is empty InStr will evaluate as 0; that should speed up a bit.
Secondly, you should get the last row of data using this:
LastRow = Report.Range("a" & Report.Rows.Count).End(xlUp).Row
LastRow2 = Report2.Range("a" & Report2.Rows.Count).End(xlUp).Row
LastRow3 = Report3.Range("a" & Report3.Rows.Count).End(xlUp).Row
"a" being the column containing the data to be checked. This will give you exactly the last non-empty row of the aimed column instead of the total used range of the entire sheet.
Also, in VBA, when you declare variables on one line, this:
Dim i, j, k As Integer
will only declare "k" as an Integer but "i" and "j" will be Variant
You should write it as:
Dim i As Integer, j As Integer, k As Integer. Same remark for Dim LastRow, LastRow2, LastRow3 As Integer
And don't forget to enable the Application.ScreenUpdating before exiting the Sub.
I have the following problem to solve to increase the speed at which the code performs the task.
I have a table with names of Hire Cars and two dates - From and To. I need to go through the range (say 10k rows) check and highlight all overlapping dates.
No Hire Car From To
1 ABC 01 Jan 12 12 Jan 12
2 ABC 14 Jan 12 15 Jan 12
3 ABC 25 Jan 12 02 Feb 12
4 DEF 01 Jan 12 12 Jan 12
5 DEF 12 Jan 12 02 Feb 12
6 DEF 14 Jan 12 15 Jan 12
For hire car DEF there are overlapping days, double counting in fact which i need to be able to highlight so that the user can quickly identify and correct.
This is the code that I have developed. The problem is that if you have a Range of 10k Rows it is extremely slow.
I am using Windows 7 Ultimate with Office/Excel 2010
Function CheckOverlap(StartLine, EndLine, StartColumn)
Dim i As Integer, y As Integer
Dim DateToCompare
Dim HireCar
Dim Count As Integer
Dim Msg, Style, Title, Response
'Check StartDate Column
For i = StartLine To EndLine
DateToCompare = Cells(i, StartColumn)
HireCar = Cells(i, 2)
For y = StartLine To EndLine
'If we are at the same line with DateToCompare cell then we should not perform any check
If i <> y Then
If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, 2) Then
'We should highlight both cells that contain overlapping dates
ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
ActiveSheet.Cells(y, StartColumn).Interior.Color = 5296274
End If
End If
Next y
Next i
HireCar = 0
'Check EndDate Column
For i = StartLine To EndLine
DateToCompare = Cells(i, StartColumn + 1)
HireCar = Cells(i, StartColumn - 1)
For y = StartLine To EndLine
'If we are at the same line with DateToCompare cell then we should not perform any check
If i <> y Then
If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, StartColumn - 1) Then
'We should highlight both cells that contain overlapping dates
ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
ActiveSheet.Cells(y, StartColumn + 1).Interior.Color = 5296274
End If
End If
Next y
Next i
'Last check: If the starting and ending date are the same
For i = StartLine To EndLine
If Cells(i, StartColumn) - Cells(i, StartColumn + 1) = 0 Then
ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
End If
Next i
' If there are no Overlap Days in Database skip filtering
' StartDate and EndDate Column
' Count Cells with Interior.Color = 5296274 (Green Colour)
Count = 0
For i = StartLine To EndLine
If Cells(i, StartColumn).Interior.Color = 5296274 Then
Count = Count + 1
End If
Next i
' Msg if Database has no Overlap Days
Msg = "Validation check completed. There are 'NO' Overlap Days"
Style = vbOKOnly
Title = "Cash Flow"
' Require on Error Resume Next in case Database is NOT filtered
On Error Resume Next
If Count = 0 Then
ActiveSheet.ShowAllData
Response = MsgBox(Msg, Style, Title)
Exit Function
Else
Call Filter_Colour
End If
MsgBox "Any Green highlights indicate Overlap Days"
End Function
The fastest approach would be to sort the table (first order: cars, second order: from-date)
Then for each line:
there is a collision iif the line above is the same car and the to-date from above is larger than the from-date of the current line.
You can do these steps either with VBA or Excel-Formulas.
Here is a simple algo to show you a blank when there's an overlap on the latter rows. To run this, it's strictly assumed that your CAR column is sorted as per sample shown in the question.
Option Explicit
'-- assuming the CAR names column is sorted
'-- so each car block in one place
'-- run on button click event
Sub FindOverlaps()
Dim i As Integer, j As Integer
Dim vInput As Variant
Dim rng As Range
Set rng = Sheets(2).Range("B2:E7")
vInput = WorksheetFunction.Transpose(WorksheetFunction.Transpose(rng))
For i = LBound(vInput) To UBound(vInput) - 1
For j = LBound(vInput) + 1 To UBound(vInput)
If vInput(i, 2) = vInput(j, 2) Then
If vInput(i, 4) = vInput(j, 3) Then
vInput(j, 3) = ""
vInput(j, 4) = ""
End If
End If
Next j
Next i
rng.Offset(0, 6).Resize(UBound(vInput), UBound(Application.Transpose(vInput))) = vInput
End Sub
Output:
EDIT AS PER OP'S COMMENT
Transpose the sorted data into the same range as per input data, so remove offset(0,4):
Add conditiona formatting to highlight anyrow that's null within the specified range. (otherwise entire sheet will be coloured where empty cells are)
Code changes:
rng.Offset(0, 6).FormatConditions.Delete
rng.Offset(0, 6).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="="""""
rng.Offset(0, 6).FormatConditions(1).Interior.ColorIndex = 20