I presently have the following coding:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim arCases As Variant
Dim res As Variant
arCases = Array("Term", "Indeterminate", "Transfer", "Student", "Term extension", "As required", "Assignment", "Indéterminé", "Mutation", "Selon le besoin", "Terme", "prolongation du terme", "affectation", "Étudiant(e)")
If Target.Address <> "$C$37" Then Exit Sub
res = Application.Match(Target, arCases, 0)
If IsError(res) Then
Rows("104:112").Hidden = False
Else
Rows("104:112").Hidden = True
End If
End Sub
The issue that I am having is that I need to add to this such as if value in Cell C37 is "X" then rows 42:49 are hidden and if value on Cell H4 is "Y" then rows 101:114 are hidden...etc.....
can you advise on how do so?
You need to change that condition to only execute the code if it matches the cell address, rather than not execute the code unless the address is matched. This will allow you to add further conditions matched on cell address.
I'd recommend changing a hard-coded cell address like "$C$37" to a named range and that named range should ideally be unique throughout the workbook.
arCases = Array("Term", "Indeterminate", "Transfer", "Student", "Term extension", "As required", "Assignment", "Indéterminé", "Mutation", "Selon le besoin", "Terme", "prolongation du terme", "affectation", "Étudiant(e)")
If Target.Address = "$C$37" Then
res = Application.Match(Target, arCases, 0)
If IsError(res) Then
Rows("104:112").Hidden = False
Else
Rows("104:112").Hidden = True
End If
ElseIf Target.Address = "$H$4" Then
' Do something else
End If
End Sub
Related
I have a code that works, but I would like to simplify it, if possible.
This codes works when the value of a cell inside a range changes. It checks if the data inserted is a number, and then divides it automatically by one hundred, so I do not have to use the character that separate integers and decimals, and this makes a lot of diference when you have thousands of numbers to insert into sheet.
My code is:
Public Sub Worksheet_Change(ByVal Target As Range)
Set Intersecao = Intersect(Target, Range("ENTRANUMEROS"))
If (Not (Intersecao Is Nothing)) And (Not IsEmpty(Intersecao)) Then
On Error GoTo Fim
Dim Entrada As Double: Entrada = Intersecao.Value
Application.EnableEvents = False
If IsNumeric(Entrada) Then
Entrada = Entrada / 100
Intersecao.Value = Entrada
Else
MsgBox ("Invalid data.")
Intersecao.Value = ""
Intersecao.Select
End If
Application.EnableEvents = True
End If
Fim:
End Sub
In VBA you can use this:
Sub TestMe()
Application.FixedDecimal = True
Application.FixedDecimalPlaces = 2
End Sub
Use the Excel option Advanced > Automatically insert a decimal point > 2
to generally add a decimal point.
There is no way to have this only for a defined range besides using VBA to switch that option:
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
Set Intersecao = Intersect(Target, Range("ENTRANUMEROS"))
If (Not (Intersecao Is Nothing)) And (Not IsEmpty(Intersecao)) Then
Application.FixedDecimal = True
Application.FixedDecimalPlaces = 2
Else
Application.FixedDecimal = False
End If
End Sub
Note that this example will not preserve the original state chosen by a user.
(Sorry for the german screenshot.)
Based on this comment of author:
I mean, insert from numeric keybord, say, 123456, and gets 1,234.56
automatically into the cell
You can devide by 100:
result = Format(Number/100, "#,##0.00")
Or, take last 2 digits as as decimals as substring:
result = MID(number, 1, LEN(number)-2)&"."& RIGHT(Number, 2)
I'm using VBA to perform a search on a pivot field and I want to be able to do a search based on whether the field contains a portion of the string but am unsure of how to do this without checking for the whole value. Bellow is what I currently have:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell
'P4 is touched
If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewPull As String
'Here you amend to suit your data
Set pt = Worksheets("Pull Code Search").PivotTables("PivotTable1")
Set Field = pt.PivotFields("Pull Code")
If IsEmpty(Range("B3").Value) = True Then
NewPull = "(All)"
Else
NewPull = Worksheets("Pull Code Search").Range("B3").Value
End If
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewPull
If NewPull = "(All)" Then
ActiveSheet.PivotTables(1).PivotFields(1).ShowDetail = False
End If
pt.RefreshTable
End With
End Sub
Use INSTR.
This function returns the position of first occurrence of substring in a string. You no need to loop through the whole string.
If your portion of the string (substring) exists in the actual "string", this function returns a positive value.
"The INSTR function can only be used in VBA code in Microsoft Excel."
The syntax
InStr( [start], string, substring, [compare] )
More description here:
https://www.techonthenet.com/excel/formulas/instr.php
I need to validate user input on when cells change and show the error in another cell in Excel using VBA.
I run into problems where my validator is called on all cells in the sheet when a user inserts rows or column which makes Excel unresponsive for a long time, how can I fix this?
Below are my requirements and my current solution with full documentation.
Definition and requirements
Consider the following table:
Example User Input Table
| | | Tolerance | | |
| Type | Length | enabled | Tolerance | Note |
|------|--------|-----------|-----------|----------------------------|
| | 4 | 0 | | Type is missing |
| | | 0 | | Type is missing |
| C | 40 | 1 | 110 | |
| D | 50 | 1 | | Tolerance is missing |
| | | | | |
The idea is that the user inputs values in the table, once a value has been changed (the user leaves the cell) the value is validated and if there is a problem the error is printed in the Note column.
Blank lines should be ignored.
I need this to be robust meaning it should not fail on any user input, that means it has to work for the following cases:
Paste values
Delete rows
Insert rows (empty or cut cells)
Insert/delete columns *
Any other case I missed thinking about?
*It is OK if the the validation fails when a user is deleting a column that is part of the table as this is seen as the user willfully vandalizing the sheet, but it has to fail gracefully (i.e. not by validating all cells in the worksheet which takes a long time). It would have been great if this action was undoable, however my current understanding of Excel suggests this is impossible (after a macro has changed something in the sheet, nothing can be undone anymore).
The Note cell can only contain one error at a time, for the user the most relevant error is the one for the cell the user last changed, so it should display this error first. After the user fixes that error the order is not that important anymore, so it could just display the errors from left to right.
Problems with current approach
My problem is that when rows/columns are inserted validation is triggered for all cells in the sheet which is a very slow process and to the user it looks like the program has crashed, but it will return once the validation is complete.
I don't know why Excel does this but I need a way to work around it.
Code placed in a Sheet named 'User Input'
My solution is based on the only on change event handler I know of: the per sheet global Worksheet_Change function (ugh!).
Worksheet_Change function
First it checks if the changed cell(s) intersects with the cells I'm interested in validating. This check is actually quite fast.
OldRowCount here is a try to catch the user inserting or deleting cells depending on how the used range changes, however this only solves some cases and introduces problems whenever Excel forgets the global variable (which happens now and then for as to me unknown reasons) as well as the first time the function is run.
The for loop makes it work for pasted values.
Option Explicit
Public OldRowCount As Long
' Run every time something is changed in the User Input sheet, it then filters on actions in the table
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRowCount As Long
NewRowCount = ActiveSheet.UsedRange.Rows.count
If OldRowCount = NewRowCount Then
If Not Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE)) Is Nothing Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed, for example while pasting cells
For Each myCell In Target.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
ElseIf OldRowCount > NewRowCount Then
'Row deleted, won't have to deal with this as it solves itself
OldRowCount = NewRowCount
ElseIf OldRowCount < NewRowCount Then
Debug.Print "Row added, TODO: deal with this"
OldRowCount = NewRowCount
End If
End Sub
Code placed in a module
Global variables
Defines the rows/columns to be validated.
Option Explicit
' User input sheet set up
Public Const ROW_FIRST = 8
Public Const COL_TYPE = "B"
Public Const COL_LENGTH = "C"
Public Const COL_TOLERANCE_ENABLED = "D"
Public Const COL_TOLERANCE = "E"
Public Const COL_NOTE = "G"
Cell checking function
This function validates the given cell unless the row where the cell is is empty.
Meaning we are only interested in validating cells on rows where the user has actually started giving values. Blank rows is not a problem.
It first validates the currently changed cell, if it is OK it will then validate the other cells on the given row (since some cells validation depends the values of other cells, see Tolerance enabled in my example table above).
The note will only ever contain one error message at a time, the above is done so that we always get the error of the last changed cell in the Note cell.
Yes, this will make the checker run twice on the current cell, while it is not a problem it could be avoided by a more complex if statement, but for simplicity I skipped it.
Sub checkInput_cell(thisRow As Long, thisCol As Long, sheet As Worksheet)
Dim note As String
note = ""
With sheet
' Ignore blank lines
If .Range(COL_TYPE & thisRow).value <> "" _
Or .Range(COL_LENGTH & thisRow).value <> "" _
Or .Range(COL_TOLERANCE_ENABLED & thisRow).value <> "" _
Or .Range(COL_TOLERANCE & thisRow).value <> "" _
Then
' First check the column the user changed
If col2Let(thisCol) = COL_TYPE Then
note = check_type(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_LENGTH Then
note = check_length(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE_ENABLED Then
note = check_tolerance_enabled(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE Then
note = check_tolerance(thisRow, sheet)
End If
' If that did not result in an error, check the others
If note = "" Then note = check_type(thisRow, sheet)
If note = "" Then note = check_length(thisRow, sheet)
If note = "" Then note = check_tolerance_enabled(thisRow, sheet)
If note = "" Then note = check_tolerance(thisRow, sheet)
End If
' Set note string (done outside the if blank lines checker so that it will reset the note to nothing on blank lines)
' only change it actually set it if it has changed (optimization)
If Not .Range(COL_NOTE & thisRow).value = note Then
.Range(COL_NOTE & thisRow).value = note
End If
End With
End Sub
Validators for individual columns
These functions takes a row and validate the a certain column according to it's special requirements. Returns a string if the validation fails.
' Makes sure that type is :
' Unique in its column
' Not empty
Function check_type(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
Dim duplicate_found As Boolean
Dim lastRow As Long
Dim i As Long
duplicate_found = False
value = sheet.Range(COL_TYPE & affectedRow).value
check_type = ""
' Empty value check
If value = "" Then
check_type = "Type is missing"
Else
' Check for uniqueness
lastRow = sheet.Range(COL_TYPE & sheet.Rows.count).End(xlUp).row
If lastRow > ROW_FIRST Then
For i = ROW_FIRST To lastRow
If Not i = affectedRow And sheet.Range(COL_TYPE & i).value = value Then
duplicate_found = True
End If
Next
End If
If duplicate_found Then
check_type = "Type has to be unique"
Else
' OK
End If
End If
End Function
' Makes sure that length is a whole number larger than -1
Function check_length(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_LENGTH & affectedRow).value
check_length = ""
If value = "" Then
check_length = "Length is missing"
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_length = "Length cannot be decimal"
ElseIf value < 0 Then
check_length = "Length is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_length = "Length contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_length = "Length is not a number"
End If
End Function
' Makes sure that tolerance enabled is either 1 or 0:
Function check_tolerance_enabled(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value
check_tolerance_enabled = ""
If Not value = "0" And Not value = "1" Then
check_tolerance_enabled = "Tolerance enabled has to be 1 or 0"
Else
' OK
End If
End Function
' Makes sure that tolerance is a whole number larger than -1
' But only checks tolerance if it is enabled in the tolerance enabled column
Function check_tolerance(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE & affectedRow).value
check_tolerance = ""
If value = "" Then
If sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value = 1 Then
check_tolerance = "Tolerance is missing"
End If
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_tolerance = "Tolerance cannot be decimal"
ElseIf value < 0 Then
check_tolerance = "Tolerance is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_tolerance = "Tolerance contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_tolerance = "Tolerance is not a number"
End If
End Function
Addressing support functions
These functions translates a letter to a column and vice versa.
Function let2Col(colStr As String) As Long
let2Col = Range(colStr & 1).Column
End Function
Function col2Let(iCol As Long) As String
Dim iAlpha As Long
Dim iRemainder As Long
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
col2Let = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
col2Let = col2Let & Chr(iRemainder + 64)
End If
End Function
Code is tested on/has to work for Excel 2010 and onwards.
Edited for clarity
Finally got it working
After quite a bit of more agonizing, it turned out the fix was quite easy.
I added a new test that checks if the area that the user changed (the Target Range) consists of a column by looking at the address of the Range, if it is a full column the checker will ignore it. This solves the problem where the validation hogs Excel for about one minute.
The result of the intersection calculation is used for the inner loop which limits checks to cells within the area we are interested in validating.
Fixed Worksheet_Change function
Option Explicit
' Run every time something is changed in the User Input sheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InterestingRange As Range
Set InterestingRange = Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE))
If Not InterestingRange Is Nothing Then
' Guard against validating every cell in an inserted column
If Not RangeAddressRepresentsColumn(InterestingRange.address) Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed,
' for example when pasting cells
For Each myCell In InterestingRange.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
End If
End Sub
New support function
' Takes an address string as input and determines if it represents a full column
' A full column is on the form $A:$A for single or $A:$C for multiple columns
' The unique characteristic of a column address is that it has always two
' dollar signs and one colon
Public Function RangeAddressRepresentsColumn(address As String) As Integer
Dim dollarSignCount As Integer
Dim hasColon As Boolean
Dim Counter As Integer
hasColon = False
dollarSignCount = 0
' Loop through each character in the string
For Counter = 1 To Len(address)
If Mid(address, Counter, 1) = "$" Then
dollarSignCount = dollarSignCount + 1
ElseIf Mid(address, Counter, 1) = ":" Then
hasColon = True
End If
Next
If hasColon And dollarSignCount = 2 Then
RangeAddressRepresentsColumn = True
Else
RangeAddressRepresentsColumn = False
End If
End Function
I'm trying to create a log in with multiple users. I have a welcome sheet with cells specifically for the username and password and a sheet with the username and password combinations.
I'm getting an error at If wk.Range("B3").Value = ws.Range(i, "A").Value Then
it says "object defined" error.
I thought it made sense to just try to check if the string in the cell matched a username/password in the users sheet through a loop.
I'm not sure if I'm going about it right. And then depending on if you log in as an operator or another user it affects which sheets you see.
Public CurrentUser As String, CurrentRole As String, LoginUserName As String, LoginPassword As String
Public LoginStatus As Boolean
Sub Login()
'Worksheets("Users").Activate
Dim numberOfUsers, i As Integer
Dim ws, wk As Worksheet
Set ws = ThisWorkbook.Worksheets("Users")
Set wk = ThisWorkbook.Worksheets("Welcome")
numberOfUsers = ws.Range("Users").Rows.Count
LoginStatus = False
For i = 1 To numberOfUsers
If wk.Range("B3").Value = ws.Range(i, "A").Value Then
If wk.Range("B4").Value = ws.Range(i, "B").Value Then
CurrentUser = wk.Range("B3").Value
LoginStatus = True
Else
LoginStatus = False
MsgBox ("Wrong Login Data")
End If
Else
LoginStatus = False
MsgBox ("Wrong Login Data")
Next i`
Select Case CurrentUser
Case "Operator"
Worksheets("Received_Calls").Visible = True
Worksheets("Welcome").Visible = False
Worksheets("Users").Visible = False
Worksheets("Reported_actions").Visible = False
Worksheets("Parameters").Visible = False
Worksheets("Distances").Visible = False
Worksheets("NewCalls").Visible = False
Worksheets("NewActions").Visible = False
Case Else
Worksheets("Received_Calls").Visible = False
Worksheets("Welcome").Visible = False
Worksheets("Users").Visible = False
Worksheets("Reported_actions").Visible = True
Worksheets("Parameters").Visible = False
Worksheets("Distances").Visible = False
Worksheets("NewCalls").Visible = False
Worksheets("NewActions").Visible = False
'need to filter
End Select
End Sub
I cant comment yet (less than 50 rep), so I'll put this in an answer, but I'd like to address a commenter above:
sous2817 - both wk and ws are dimensioned as worksheets, so the comparison is correct.
Now to the Answer:
As Dirk states, the workbook.Range() function takes two arguments, but they should both be cell addresses in string format, and if both are supplied, the range returned will include all cells between them. You have:
ws.Range(i, "A").Value
which is telling excel to get cell i and cell "A" and get all cells in a square between them. This won't work because there is no such cell as "A" (and you would refer to column A as "A:A"), and the variable i will evaluate to a number (again there is no such address as 1,2,3, etc, only "1:1" etc)
What you need to change this to is, as Dirk says:
ws.Range("A" & i).value
The ampersand (&) acts as a concatenator, and will create a string for each iteration of the loop, evaluating into A1, A2, A3 etc.
You will need to do the same for the Range function that references column B as well.
Having said all that, a better solution would the answer eluded to by sous2817 in their second comment in that you could do this:
Dim userCell as Range
Set userCell = ws.Range("Users").Resize(,1).Find(wk.Range("B3").Value)
If userCell is nothing then
'Username is invalid code goes here
Elseif wk.Range("B4").Value = userCell.offset(,1).value then
'Password is valid
Else
'Password is invalid
End If
As findwindow stated, you can expand upon this by first checking if the username supplied matches Application.UserName to see if it is the current windows user.
Hope this helps!
I have a pivot table from ssas connection. Several pivotfields are being used in the table. For this example let's say they are Size, Color, and Location. My goal is to write some vba where I pass the cell range and get the value of the corresponding pivotfields.
For example, If I pass the cell range for B6 I want to know that that cell is from location2 in color2 for size1. If I pass range B8 I get location1, Color3, Size1 etc.
Here is what I can do so far. I can get the value of the formula for that cell. Here is the result for B6: GETPIVOTDATA("[Measures].[myValues]",$A$1,"[d size].[size]","[d size].[size].&[Size1]","[d color].[color]","[d color].[color].&[Color2]","[d location].[location]","[d location].[location].&[location2]") with this code:
Function xxx(ByVal xyz As Range) As Variant
xxx = xyz.Formula
End Function
Sub blah()
MsgBox (xxx(ActiveWorkbook.Sheets("Sheet1").Range("D13")))
End Sub
I can also loop through the pivotfields and get their names, (but I don't know how to get their values) [Measures].[myValues], [d size].[size] etc... with this code:
With Worksheets("Sheet1").PivotTables(1)
For i = 1 To .PivotFields.Count
MsgBox .PivotFields(i).Name
Next
End With
My question is now, how do I get the value of those pivotfields for a particular cell. I would like to be able to send B6 and get back, or have access to: location2, Color2, Size1
Edit:
Getting closer... I can now loop through each field and get their names and values like this [d size].[size]&[Size1] etc, but now I want to be able to get just the value of Size1 or [Size1]:
Sub Test()
Dim iRange As Variant
iRange = ActiveCell.Address
FieldPicker (iRange)
End Sub
Function FieldPicker(targetCell As Variant) As Variant
With Range(targetCell).PivotCell
For i = 1 To .RowItems.Count
MsgBox .RowItems(i).SourceName
Next
End With
End Function
Adapted from RoryA's answer here: http://www.mrexcel.com/forum/excel-questions/332678-pivottable-problem.html
'Given a pivottable value cell and a category name, return the category value
'Note: you would need morte code to account for a "page" category
Function PivotCategoryValue(rngInput As Range, fldName As String) As String
Dim pc As PivotCell
Dim pf As PivotField, pi As PivotItem
Dim rv As String
On Error Resume Next
Set pc = rngInput.PivotCell
On Error GoTo err_handle
If pc Is Nothing Then
rv = "Not a pivot cell"
Else
Select Case pc.PivotCellType
Case xlPivotCellValue
If pc.RowItems.Count Then
For Each pi In pc.RowItems
If pi.Parent.Name = fldName Then
rv = pi.Value
GoTo done
End If
Next pi
End If
If pc.ColumnItems.Count Then
For Each pi In pc.ColumnItems
If pi.Parent.Name = fldName Then
rv = pi.Value
GoTo done
End If
Next pi
End If
Case Else
rv = "Not a pivot data cell"
End Select
End If
done:
PivotCategoryValue = rv
Exit Function
err_handle:
PivotCategoryValue = "Unknown error"
End Function