The following bit of VBA will highlight any cells in a sheet with data validation errors:
Sub CheckValidation(sht As Worksheet)
Dim cell As Range
Dim rngDV As Range
Dim dvError As Boolean
On Error Resume Next
Set rngDV = sht.UsedRange.SpecialCells(xlCellTypeAllValidation)
On Error GoTo 0
If rngDV Is Nothing Then
sht.ClearCircles
Else
dvError = False
For Each cell In rngDV
If Not cell.Validation.Value Then
dvError = True
Exit For
End If
Next
If dvError Then
sht.CircleInvalid
sht.Activate
Else
sht.ClearCircles
End If
End If
End Sub
However, the "For Each" loop runs really slowly in sheets with a lot of data validation.
Does anyone know of a way to avoid the "For Each" loop, or speed it up somehow?
I would have thought that the following would be equivalent to set the value of 'dvError':
dvError = Not rngDV.Validation.Value
But for some reason, rngDV.Validation.Value is true even when there are data validation errors.
I had a slightly different requirement where I wanted to restrict the values entered by a user to a valid date range or the text "ASAP" which I resolved using the following;
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sErr As String
Dim sProc As String
On Error GoTo ErrHandler
Application.EnableEvents = False
Select Case Target.Column
Case 11
sProc = "Validate Date"
'The value must be a date between "1 Nov 2011" and "30 Jun 2012" or "ASAP"...
If IsDate(Target.Value) Then
If Target.Value < CDate("2011-11-01") _
Or Target.Value > CDate("2012-06-30") Then
Err.Raise vbObjectError + 1
End If
ElseIf LCase(Target.Value) = "asap" Then
Target.Value = "ASAP"
ElseIf Len(Trim(Target.Value)) = 0 Then
Target.Value = vbNullString
Else
Err.Raise vbObjectError + 1
End If
End Select
ErrHandler:
Select Case Err.Number
Case 0
'Nothing to do...
Case vbObjectError + 1
sErr = "The Date must be between ""1 Nov 2011"" and ""30 Jun 2012"" or equal ""ASAP""."
Case Else
sErr = Err.Description
End Select
If Len(Trim(sErr)) > 0 Then
Target.Select
MsgBox sErr, vbInformation + vbOKOnly, sProc
Target.Value = vbNullString
End If
Application.EnableEvents = True
End Sub
Tried your code and it's working quite fast with 4536 cells containing validations - as you are rightly breaking your FOR at the first occurence of an unvalidated cell
I tried to measure time at various points of your code by following:
Dim Tick As Variant
Tick = Now()
' ... code
Debug.Print "ValCount", rngDV.Cells.Count ' just to see how many cells are in that range
' ... code
Debug.Print "Pt1", (Now() - Tick) * 86400000 'display milliseconds
' ... code
Debug.Print "Pt2", (Now() - Tick) * 86400000 'display milliseconds
' ... code
Debug.Print "Pt3", (Now() - Tick) * 86400000 'display milliseconds
' etc.
and got a not measureable delay (except when stepping thru debugger with F8 - of course)
As a generic hint ... try to find out where exactly your code is slow and let's take it from there.
Related
I have a macro (below) that inserts a new row into an un-defined number of Named ranges using ParamArray, it works fine except for when I try to assign the macro with more than 5-6 arguments I get a message box that says "Formula Too Complex to Assign To Object" (see picture above)
(see assignment string below)
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool", "SAP_SCD_OutPool", "SAP_SCD_SecondaryIn", "SAP_SCD_SecondaryOut", "SAP_SCD_ORD","SAP_SCD_THF","SAP_SCD_LH", "SAP_SCD_LH"'
Macro:
Sub InsertNewRow(ParamArray args() As Variant)
Dim ans: ans = MsgBox("WARNING: " & vbNewLine _
& "Action Cannot be undone!" & vbNewLine & "Continue?", vbYesNo, "Warning!")
If ans = vbNo Then: Exit Sub
Call HaltOperations
Call ActiveSheet.Unprotect()
Call Sheets("SAP Timesheet").Unprotect()
On Error GoTo OnError_Exit
'Loop and Check All Named Ranges Exist Before Proceeding
For Each a In args
If RangeExists(a) = False Then
MsgBox ("Named Range: " & a & " Not Defined!" & vbNewLine & "Operation Cancelled")
Exit Sub
End If
Next a
Dim rng As Range
'ADD ROW TO EACH NAMED INPUT RANGE
For Each a In args
Set rng = Range(a)
With rng
.Rows(.Rows.count).EntireRow.Insert
.Rows(.Rows.count - 2).EntireRow.Copy
.Rows(.Rows.count - 1).EntireRow.PasteSpecial (xlPasteFormulasAndNumberFormats)
On Error Resume Next: .Rows(.Rows.count - 1).EntireRow.PasteSpecial (xlPasteFormats)
End With
Next a
On Error GoTo OnError_Exit
'ADJUST HEIRACHY NUMBERS ON FIRST INPUT RANGE (MANNING TAB)
Set rng = Range(args(0))
Dim col As Integer
col = rng.Column
Cells(rng.Row + rng.Rows.count - 2, col).Offset(0, -1).Value _
= Cells(rng.Row + rng.Rows.count - 3, col).Offset(0, -1).Value + 1
Cells(rng.Row + rng.Rows.count - 1, col).Offset(0, -1).Value _
= Cells(rng.Row + rng.Rows.count - 3, col).Offset(0, -1).Value + 2
Call ResumeOperations
Application.CutCopyMode = False
Call ActiveSheet.Protect()
Call Sheets("SAP Timesheet").Protect()
Exit Sub
OnError_Exit:
Call ResumeOperations
Application.CutCopyMode = False
Call ActiveSheet.Protect()
Call Sheets("SAP Timesheet").Protect()
End Sub
Private Function RangeExists(rng As Variant) As Boolean
Dim Test As Range
On Error Resume Next
Set Test = Range(rng)
RangeExists = Err.Number = 0
End Function
Private Sub HaltOperations()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
End Sub
Private Sub ResumeOperations()
ResumeOps:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
The Macro itself runs as expected it's just the assigning the named ranges that is causing the issue.
is there a better way to do this?
or is there a way to get around the Formula is too complex method?
and if there is will that need to be done on all end user pc's or just on mine and the settings will carry over?
What I have thought about doing was just taking in 2 Named ranges and then for the following ranges Just offsetting those by the Row Count of the previous range so if Range2 = Sheets().Range("A1:A10") then Range3 = Range2.Offset(Range2.Rows.Count,0) then the assingment input would only need to be Range1 as string, Range2 as string, NumberOfExtraRanges as integer the reason I need atleast two ranges is because every range after range 1 is on a different tab and is essentially a raw data version of all pay info hours etc. in the first tab which will be Range1_EmployeeList
which I will play around with while I wait for a response.
TIA
Not a Complete answer but I did find that inside the ParamArray I could just assign One Input Range using a , to seperate each defined range. I haven't tested the limitations doing it this way but it does seem to atleast let me use a few extra inputs.
Example (Not Working):
Note: Each Defined Range is a Separate Input
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool" ," SAP_SCD_OutPool","SAP_SCD_SecondaryIn", "SAP_SCD_SecondaryOut"'
Example (Working):
Note Each Defined Range is passed as 1 input
'InsertNewRow "ServiceCrewDay_EmployeeList", "SAP_SCD_InPool, SAP_SCD_OutPool,SAP_SCD_SecondaryIn,SAP_SCD_SecondaryOut"'
I have written a code that finds all the dye word and sum all the dye word value.
Here is the code
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = Range("Q10:S61")
Set firstDyeWord = findDyeRange.Find(name)
If firstDyeWord Is Nothing Then
msgbox "nothing found"
Else
firstDyeValue = firstDyeWord.Offset(0, 1).Value
Set secondDyeWord = findDyeRange.FindNext(firstDyeWord)
If secondDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue
Exit Sub
Else
secondDyeValue = secondDyeWord.Offset(0, 1).Value
Set thirdDyeWord = findDyeRange.FindNext(secondDyeWord)
If thirdDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue
Exit Sub
Else
thirdDyeValue = thirdDyeWord.Offset(0, 1).Value
Set fourthDyeWord = findDyeRange.FindNext(thirdDyeWord)
If fourthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue
Exit Sub
Else
fourthDyeValue = fourthDyeWord.Offset(0, 1).Value
Set fifthDyeWord = findDyeRange.FindNext(fourthDyeWord)
If fifthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue
Exit Sub
Else
fifthDyeValue = fifthDyeWord.Offset(0, 1).Value
Set sixthDyeWord = findDyeRange.FindNext(fifthDyeWord)
If sixthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue
Exit Sub
Else
sixthDyeValue = sixthDyeWord.Offset(0, 1).Value
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue + sixthDyeValue
End If
End If
End If
End If
End If
End If
the code runs well. But when I removes the msgbox and set a code then it throws an error.
I want this code
If firstDyeWord Is Nothing Then
Range("A9").value = 7
But it throws error "method find of object range failed in vba"
Help Please!
According to the documentation of the Range.Find method you must at least specify the parameters LookIn, LookAt, SearchOrder and MatchByte when using Find() otherwise it uses what ever was used last by either VBA or the user interface.
Since you cannot know what your users used last in the user interface your search might randomly work and randomly come up with wrong results. Therefore always specify all of these 4 parameters to make it reliable.
Additionally you must specify in which workbook/worksheet your ranges are. Otherwise Excel guesses and it might guess the wrong sheet.
Make sure to declare all your variables properly. I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
Public Sub Example()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
ws.Range("A9").Value = 7 'specify in which sheet the range is
Else
'do something else if dye was found
End If
End Sub
// Edit (see comment)
If this is used in an event like Worksheet_Change you need to turn off events before writing to a cell. Otherwise this will trigger another event which will trigger another event … and you get stuck in an endless loop of events, which cannot work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
On Error Goto REACTIVATE_EVENTS 'in any case of error reactivate events
Application.EnableEvents = False 'disable events or .Value = 7 triggers another change event.
ws.Range("A9").Value = 7 'specify in which sheet the range is
Application.EnableEvents = True 'make sure you never leave events disabled otherwise they will stay off until you restart Excel.
Else
'do something else if dye was found
End If
Exit Sub
REACTIVATE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext 'show error message if there was an error.
End Sub
I have multiple textboxes on multiple userforms that are for time allocations. For simplicity say userform1 & userform2, with textbox1 & textbox2 on each.
Userform1 is for user input, which places values into a table and userform2 pulls the values from this table and displays in the relevant textbox. I need to restrict both the input of these boxes and the display to the [H]:mm format where minutes cannot exceed 59 but hours can be 25+ i.e 125:59 but not 4:67
I tried a combination of code from both of these threads as well as others but can't seem to get it to work.
Excel VBA Textbox time validation to [h]:mm
Time format of text box in excel user form
eventually i just tried to manipulate user input with message boxes but this still leaves entries open to error
Sub FormatHHMM(textbox As Object)
Dim timeStr As String
With textbox
'Check if user put in a colon or not
If InStr(1, .Value, ":", vbTextCompare) = 0 And Len(.Value) > 1 Then
MsgBox "Please use HH:mm Format"
textbox.Value = ""
textbox.SetFocus
Else
If Right(.Value, 2) > 60 Then
MsgBox "Minutes cannot be more than 59"
textbox.Value = ""
textbox.SetFocus
End If
End If
End With
End Sub
this allows users put alpha characters in and even if correctly input when called from the table is shows as a value instead i.e 5.234... instead of 125:59
How about you split hours and minutes into two seperate input fields on the same inputbox.
So the user has to type in hours and in the next field minutes. This way you can check the input for isnumeric and >60 for seconds.
I know this is not ideal, but it would be a way to evade the given problems.
Have you tried using the Like operator? That allows checking for numeric values in each character-position. I would do it like this:
Function FormatCheck(ByVal strEntered As String)
Dim correctformat As Boolean
If strEntered Like "*#:##" And IsNumeric(Mid(strEntered, 1, InStr(1, strEntered, ":", 1) - 1)) Then
If Mid(strEntered, InStr(1, strEntered, ":", 1) + 1, 999) <= 59 Then
correctformat = True
End If
End If
If Not correctformat Then FormatCheck = "Incorrect format"
End Function
This requires at least one number before the ":"
Edit: Below is a Sub version instead of using a Function. This will pop up a MsgBox like you were using originally. You could probably replace your whole FormatHHMM sub with this without any adverse effect.
Sub FormatCheck(ByVal strEntered As String)
Dim correctformat As Boolean
If strEntered Like "*#:##" And IsNumeric(Mid(strEntered, 1, InStr(1, strEntered, ":", 1) - 1)) Then
If Mid(strEntered, InStr(1, strEntered, ":", 1) + 1, 999) <= 59 Then
correctformat = True
End If
End If
If Not correctformat Then MsgBox "Incorrect format"
End Sub
i think this may be helpful:
Option Explicit
Sub test()
Dim str As String
str = TextBox.Value
'Test string lenght. Maximun lenght number 4
If Len(str) <> 4 Then
MsgBox "Enter a valid time. Proper number of digits are 4."
Exit Sub
End If
'Test if string includes only one ":"
If (Len(str) - Len(Replace(str, ":", ""))) / Len(":") <> 1 Then
MsgBox "Use only one "":"" to separate time."
Exit Sub
End If
'Test how many digits are before and after ":"
If InStr(1, str, ":") <> 2 Then
MsgBox """:"" position should be place 2."
Exit Sub
End If
'Test if number 1,3 & 4 are number
If IsNumeric(Mid(str, 1, 1)) = False Or IsNumeric(Mid(str, 1, 1)) = False Or IsNumeric(Mid(str, 1, 1)) = False Then
MsgBox "Enter number in position 1,3 and 4."
Exit Sub
End If
'Test 2 last to digits
If Right(str, 2) <= 60 Then
MsgBox "Second limit is 60."
Exit Sub
End If
End Sub
You could use regular expressions :
Sub inputTimeFormat()
Dim userInput As String
Dim strPattern As String
Dim msgBoxText As String
Dim regEx As New RegExp
Dim objRegex As Object
strPattern = "(^[0-9]+):([0-5])([0-9])$"
msgBoxText = "Insert time in HH:mm, or hit Cancel to escape"
Set objRegex = CreateObject("vbscript.regexp")
With regEx
.ignorecase = True
.Pattern = strPattern
Do
If userInput <> vbNullString Then msgBoxText = "PLEASE RETRY" & Chr(13) & msgBoxText
userInput = Application.InputBox(msgBoxText, Default:="17:01")
If userInput = "False" Then
MsgBox "User hit cancel, exiting code", vbCritical
Exit Sub
End If
Loop Until .Test(userInput)
End With
MsgBox "Format OK"
End Sub
(you need to activate regular expressions : in VBA, "Tools" > "References" > Check the box "Microsoft VBScript Regular Expressions 5.5" > "OK")
More details on How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops
I have a small user interface, using Excel's Form functionality, which allows users to input start and finish dates for projects.
If the user puts in dates that are available in both the US and UK formats (e.g. 7th May 2018, 5/7/2018) the variable will come out in the US format (e.g. 5th July 2018, 5/7/2018). However, if the dates are not available in both formats (e.g. 31st August 2018, 31/8/2018), the variable will return in the (correct) UK format.
My current code for the particular variables in the form is as follows:
Private Sub Calculate_Click()
sDate = CDate(sDate.Text)
eDate = CDate(eDate.Text)
If sDate = vbNullString Then
sDate = Now()
End If
If eDate = vbNullString Then
eDate = Now() + 40
End If
If HoursPD = vbNullString Then
HoursPD = 6
ElseIf HoursPD > 7.5 Then
HoursPD = 7.5
End If
Me.Hide
End Sub
Is there any way to ensure that the variable format is fixed to the UK version?
I'd use a separate procedure to check any dates on the form.
This also colours the control red if a non-valid date is entered.
Formatting the date as dd-mmm-yyyy makes it easier to spot a date in the wrong format as month is written in full(ish).
Public Sub FormatDate(ctrl As Control)
Dim dDate As Date
Dim IsDate As Boolean
On Error GoTo ERR_HANDLE
If Replace(ctrl.Value, " ", "") <> "" Then
On Error Resume Next
dDate = CDate(ctrl.Value)
IsDate = (Err.Number = 0)
On Error GoTo 0
On Error GoTo ERR_HANDLE
If IsDate Then
ctrl.Value = Format(ctrl.Value, "dd-mmm-yyyy")
ctrl.BackColor = RGB(255, 255, 255)
Else
ctrl.BackColor = RGB(255, 0, 0)
End If
End If
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
'Error Handling routines.
'DisplayError Err.Number, Err.Description, "mdl_FormatDate.FormatDate()"
Resume EXIT_PROC
End Sub
This is then called on the AfterUpdate event of the control:
Private Sub txtDate_AfterUpdate()
On Error GoTo ERR_HANDLE
With Me
FormatDate .txtDate
End With
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
'Error Handling routines.
'DisplayError Err.Number, Err.Description, "Data_Entry_Form.txtDate_AfterUpdate()"
Resume EXIT_PROC
End Sub
You could do something like below, but your users should know to enter the dates in the correct (UK) format:
sDate = Format(CDate(sDate.Text), "dd/mm/yyyy")
EDate = Format(CDate(EDate.Text), "dd/mm/yyyy")
I'm having some trouble with an Excel VBA macro and was hoping you could give me some advice on how to fix it. In the code below, when a user clicks a command button, an InputBox pops up and the user inputs a number in the form XXX-XXXXXX (e.g. 111-222222). Then, the macro takes the value from the column adjacent to button and uses the input variable to replace a certain part of the adjacent column's value. However, when I tried to run the macro and input a number such as 123-456789, nothing happens. I believe it has something to do with the dash that the user inputs, however I'm not sure how to fix it. Please help!
Sub CommandButtonTitleXXXdashXXXXXX_Click()
Application.ScreenUpdating = False
On Error Resume Next
Dim n As Integer
n = Worksheets("REVISIONS").Range("D3:D17").Cells.SpecialCells(xlCellTypeConstants).Count
If n = 15 Then
If MsgBox("Title revision box full. Add manually.", vbOKOnly, "Error") = vbOK Then
Exit Sub
End If
End If
Dim rs As Integer
rs = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
Dim amount As String
Application.ScreenUpdating = True
amount = Application.InputBox("Enter case number:", "")
Application.ScreenUpdating = False
If amount = False Then
Exit Sub
Else
Dim newCell As String
newCell = Replace(Worksheets("TITLE").Range("A" & rs).Value, "XXX-XXXXXX", amount)
Worksheets("REVISIONS").Range("D17").End(xlUp).Offset(1, 0) = newCell
End If
End Sub
I would take your code to an extra step.
No need to declare amount as String. You can keep it as a Variant. Also like I mentioned in the comment above
Can your Case number be like #D1-1%#456? If not then you have an additional problem to handle ;)
See this example. I have commented the code so that you will not have a problem understanding it. Still if you do lemme know :) The other way would be to use REGEX to validate your Case ID. Let me know if you want that example as well.
Code
Sub Sample()
Dim amount As Variant
' 123-$456789 <~~ Invalid
' 123-4567890 <~~ Valid
' ABC-&456789 <~~ Invalid
' 456-3456789 <~~ Valid
amount = Application.InputBox("Enter case number:", "")
'~~> Check if user pressed cancel
If amount = False Then Exit Sub
'~~> Check if then Case ID is valid
If IsValidCaseNo(amount) Then
MsgBox amount
Else
MsgBox "Invalid case ID"
End If
End Sub
Function IsValidCaseNo(sAmount) As Boolean
Dim s As String
Dim i As Long, j As Long
s = sAmount
'
'~~> Initial basic checks
'
'~~> Check if the length is 11 characters
If Len(Trim(s)) <> 11 Then GoTo Whoa
'~~> Check if the string contains "-"
If InStr(1, s, "-") = 0 Then GoTo Whoa
'~~> Check if the 4th character is a "-"
If Mid(s, 4, 1) <> "-" Then GoTo Whoa
'~~> Loop through 1st 3 characters and check
'~~> If they are numbers
For i = 1 To 3
Select Case Asc(Mid(s, i, 1))
Case 48 To 57
Case Else: GoTo Whoa
End Select
Next
'~~> Loop through last 6 characters and check
'~~> If they are numbers
For i = 5 To 11
Select Case Asc(Mid(s, i, 1))
Case 48 To 57
Case Else: GoTo Whoa
End Select
IsValidCaseNo = True
Next
Whoa:
End Function
If you Dim amount as String, you can test it as a string:
Sub GetDash()
Dim amount As String
amount = Application.InputBox(Prompt:="Enter case number", Type:=2)
If amount = "False" Then
MsgBox "You cancelled"
End If
End Sub