I have a spreadsheet that uses a filter on a few columns of data. One of these columns has 10 different possible values. I want to verify that there is a specific filter in place--that is, not just that autofiltermode = true--but to actually check what the value of that filter is. Is there a way to do this in vba?
For example, if I might want to make sure that the user is only looking at customers, 1 of the 10 values in my field. So I'm hoping I can say something like if filtervalue = "customers" then.
Additionally, I don't want to verify cell data, I'm asking if there's a way to verify a filter.
The sample code below will check for the criteria selections given the first cell of the range containing the filter, and the index of the column to check.
Option Explicit
Sub Test()
'first argument is first cell of headers being filtered
'second argument is column to check for filter criteria
Debug.Print GetCriteria(Sheet1.Range("A1"), 3)
End Sub
Function GetCriteria(rng As Range, lngFilterIndex As Long) As String
Dim strCriteria As String
Dim objFilter As AutoFilter
Dim lngCriteriaCount As Long
Dim lngCounter As Long
Set objFilter = rng.Parent.AutoFilter
' no autofilter
If objFilter Is Nothing Then
GetCriteria = ""
Exit Function
End If
' autofilter but no selection
If Not objFilter.Filters(lngFilterIndex).On Then
GetCriteria = ""
Exit Function
End If
' iterate criteria
strCriteria = ""
lngCriteriaCount = objFilter.Filters(lngFilterIndex).Count
If lngCriteriaCount = 1 Then
strCriteria = objFilter.Filters(lngFilterIndex).Criteria1
Else
For lngCounter = 1 To objFilter.Filters(lngFilterIndex).Count
strCriteria = strCriteria & objFilter.Filters(lngFilterIndex).Criteria1(lngCounter)
Next lngCounter
End If
GetCriteria = strCriteria
End Function
Related
I'm new to VBA and am trying to cobble together some code to allow a user to input a word (or several words) into a cell and then show a list of matching row entries.
I have tried the following code but am getting an "instring = type mismatch" error.
Note that "B3" is the field dedicated for the "search word" and column F is the column containing the text I want to search within. If the word is contained, I want to show that row and hide all rows that don't contain that word.
Sub Find_Possible_Task()
ROW_NUMBER = 0
SEARCH_STRING = Sheets("codeset").Range("B3")
ROW_NUMBER = ROW_NUMBER + 1
ITEM_IN_REVIEW = Sheets("codeset").Range("F:F")
If InStr(ITEM_IN_REVIEW, SEARCH_STRING) Then
Do
Cells(c.Row).EntireRow.Hidden = False
Loop Until ITEM_IN_REVIEW = ""
End If
End Sub
TIA!
Few bad coding conventions or even possibly downright errors:
It's a good practice to explicity declare the scope Public/Private of your Sub procedure
Unless you're passing the variables from some place else, they need to be declared with Dim keyword
Using Option Explicit will help you prevent aforementioned error(s)
(Subjective) variables in all caps are ugly and in most programming languages it is convention to reserve all caps variables names for constants (Const)
Option Explicit
Private Sub keep_matches()
Dim what As Range
Dim where As Range
Dim res As Range ' result
Dim lr As Long ' last active row
Dim ws As Worksheet: Set ws = Sheets("codeset")
lr = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Set what = ws.Range("B3")
Set where = ws.Range("F1:F" & lr)
' we'll create an extra column for a loop in our .Find method
where.Copy
ws.Range("F1").EntireColumn.Insert
ws.Range("F1").PasteSpecial xlPasteValues
where.EntireRow.Hidden = True ' preemptively hide them all
Set where = ws.Range("F1:F" & lr)
Set res = where.Find(what, lookIn:=xlValues) ' ilook for matches, 1st attempt
If Not res Is Nothing Then ' if found
Do Until res Is Nothing ' repeat for all results
res.EntireRow.Hidden = False
res = "Checked"
Set res = where.FindNext(res)
Loop
Else
MsgBox("No matches were found")
where.EntireRow.Hidden = False ' we don't wanna hide anything
End If
ws.Range("F1").EntireColumn.Delete ' remove the extra help column for Find method
End Sub
Should work as expected.
If there are any question, let me know.
instead of instr(), consider range.find().
Sub Find_Possible_Task()
Dim SEARCH_STRING As String
Dim ITEM_IN_REVIEW As Range
Dim found As Range
Dim i As Integer
SEARCH_STRING = Sheets("Sheet1").Range("B3").Value
i = 1
Do
Set ITEM_IN_REVIEW = Sheets("Sheet1").Cells(i, 6)
Set found = ITEM_IN_REVIEW.Find(What:=SEARCH_STRING)
If found Is Nothing Then
ITEM_IN_REVIEW.EntireRow.Hidden = True
End If
i = i + 1
Loop Until ITEM_IN_REVIEW = ""
End Sub
alternatively, consider using filter table:
1. check if your table has filter on ==> if yes, pass. if no, turn on filter.
2. filter column F for keyword to contain value in cell B3.
I'm using a filter on a sheet in Excel. All I want to do is uncheck "empty cells" in field 1 of my filterrange. I know how to uncheck the "empty cells" but the existing filter (made by user) must stay active.
Code I'm using to get the name of the filterrange:
Dim obj As ListObject
Dim Tabel As String
Dim filter As Boolean
filter = False
For Each obj In ActiveSheet.ListObjects
Tabel = obj.Name
Exit For
Next
Code that I use to uncheck "empty cells" when no filter is applied:
ActiveSheet.ListObjects(Tabel).Range.AutoFilter field:=1, Criteria1:="<>"
What I prefer to get is the actual filter used in field 1, add the criteria:="<>" do my thing en reapply the filter applied by the user.
Thing I was trying:
Dim ActieveFilters As String
Dim FilterArray()
Dim LaatsteFilter As Long
Dim i As Long
With ActiveSheet.ListObjects(Tabel).AutoFilter.Filters(1)
ReDim FilterArray(1 To .Count)
For f = 1 To .Count
With .Item(f)
If .On Then
FilterArray(f) = Criteria1
End If
End With
Next f
End With
Active filters
First post yall.
Long story short, in Excel, when I call the following function (it's in its own module) from a cell, it returns the wrong value. The function returns the correct value when calling it from a sub, as well as when I step through the code (to the end), but the moment I call it from Excel, it returns a different value. Background at the bottom.
Things I've Tried
Making it a Public Function
Giving it an argument
Changing the function and/or module name
Moving it out of a module
Restarting Excel
A bunch of random stuff
It really is just this specific function that's giving me this issue, simpler functions do what they're told. I have to assume it has something to do with the order of events Excel is doing things, or the limits of what parts of Excel a function can change.
Function ActiveDisciplineFilters()
Application.Volatile 'makes the function update automatically
Dim disccolumn As Range
Dim uniquedisc() As String
Dim uniquediscstring As String
'create a string of unique values from the Discipline column
i = 0
If Range("LayerList[Discipline]").SpecialCells(xlCellTypeVisible).Address = Range("LayerList[Discipline]").Address Then
ActiveDisciplineFilters = "None"
Exit Function
End If
For Each cell In Range("LayerList[Discipline]").SpecialCells(xlCellTypeVisible)
If InStr(1, uniquediscstring, cell.Value) = 0 Then
If i <> 0 Then
uniquediscstring = uniquediscstring & ", " & cell.Value
Else
uniquediscstring = cell.Value
i = 1
End If
End If
Next
ActiveDisciplineFilters = uniquediscstring
End Function
Background
In Excel, I have a table. I'm taking all the data in one specific column of that table and creating a string of the unique values in that range (separated by comma). That string must be placed in another cell, for reasons I don't need to get into. If a filter is applied to the column, the unique values update automatically.
What would make Excel give me the right answer when I call it from a sub, then the wrong one when I call it from a cell?
Unfortunately, none of the SpecialCells methods work in a UDF. If you need this to be run from the worksheet as a formula, then your code should look like this instead:
Function ActiveDisciplineFilters()
Application.Volatile 'makes the function update automatically
Dim disccolumn As Range
Dim uniquedisc() As String
Dim uniquediscstring As String
Dim i As Long
Dim cell As Range
Dim bHidden As Boolean
'create a string of unique values from the Discipline column
i = 0
For Each cell In Range("LayerList[Discipline]").Cells
If cell.EntireRow.Hidden = False Then
If InStr(1, uniquediscstring, cell.Value) = 0 Then
If i <> 0 Then
uniquediscstring = uniquediscstring & ", " & cell.Value
Else
uniquediscstring = cell.Value
i = 1
End If
End If
Else
bHidden = True
End If
Next
If Not bHidden Then uniquediscstring = "None"
ActiveDisciplineFilters = uniquediscstring
End Function
I have a couple of tables and want to replace column 2 or column 5 (if it exists) with check boxes.
If there is an asterisk in the cell, I want the check box checked = True.
If there's no asterisk, the cell will only be a unchecked check box. These check boxes are from the developer tab, under controls, legacy forms.
I researched but failed:
replacing an asterisk with a check box (checked)
limiting it to a specific column (see image)
replacing a blank cell with a check box (unchecked)
limiting the action to a specific column (2 and 5 (if it exists))
Dim oCell As Cell
Dim oRow As Row
For Each oRow In Selection.Tables(1).Rows
For Each oCell In oRow.Cells 'this won't work specifically with my example, needs to be a little more specific
If oCell.Range.Text = "*" Then
MsgBox oCell.RowIndex & ", " & oCell.ColumnIndex & " check it!"
'I don't how to put in a check box here
End If
Next oCell
Next oRow
'I want to combine the top code and code below...right?
'do for each cell in column 2
With ActiveDocument.FormFields.Add(Range:=ActiveDocument.Selection, Type:=wdFieldFormCheckBox)
If cellvalue = "" Then 'just verbal logic here
.CheckBox.Value = False
End If
If cellvalue = "*" Then 'just verbal logic here
.checkbox.Value = True
End If
End With
Here's how I would do this:
Dim objDoc As Document
Dim oCell As Cell
Dim oCol As Column
Dim objTable As Table
Dim bFlag As Boolean
Set objDoc = ActiveDocument
Set objTable = Selection.Tables(1)
'This may or may not be necessary, but I think it's a good idea.
'Tables with spans can not be accessed via the spanned object.
'Helper function below.
If IsColumnAccessible(objTable, 2) Then
For Each oCell In objTable.Columns(2).Cells
'This is the easiest way to check for an asterisk,
'but it assumes you have decent control over your
'content. This checks for an asterisk anywhere in the
'cell. If you need to be more specific, keep in mind
'that the cell will contain a paragraph return as well,
'at a minimum.
bFlag = (InStr(oCell.Range.Text, "*") > 0)
'Delete the content of the cell; again, this assumes
'the only options are blank or asterisk.
oCell.Range.Delete
objDoc.FormFields.Add Range:=oCell.Range, Type:=wdFieldFormCheckBox
'Set the value. I found some weird results doing this
'any other way (such as setting the form field to a variable).
'This worked, though.
If bFlag Then
oCell.Range.FormFields(1).CheckBox.Value = True
End If
Next oCell
End If
'Then do the same for column 5.
Public Function IsColumnAccessible(ByRef objTable As Table, iColumn As Integer) As Boolean
Dim objCol As Column
'This is a little helper function that returns false if
'the column can't be accessed. If you know you won't have
'any spans, you can probably skip this.
On Error GoTo IsNotAccessible
IsColumnAccessible = True
Set objCol = objTable.Columns(iColumn)
Exit Function
IsNotAccessible:
IsColumnAccessible = False
End Function
I need to find a cell into a worksheet but I'd like to avoid looking for a string.
The problem I have is that the worksheet will be edited by my client. If ever he decides to write the string I'm looking for before the good one, the app will crash.
Sub FindSpecificCell()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("TP 1")
Dim myRange As Range
Dim rangeFinal As Range
Set monRange = ws.Range("A:AJ")
Set rangeFinal = myRange.Find("Description du test")
Debug.Print " "
Debug.Print "Looking for ""Description du test"" in TP 1 "
Debug.Print "column : " & rangeFinal.Column
Debug.Print "row : " & rangeFinal.Row
End Sub
Is there a way to insert a kind of property inside the cell in order to be sure that I'm working on the good one?
You can't associated properties with a specific cell directly, but you can use properties with the worksheet to store this information. I've used a couple methods like this before:
'Set the provided value of the custom property with the provided name in the provided sheet.
Private Sub SetCustomPropertyValue(InSheet As Worksheet, WithPropertyName As String, WithValue As Variant)
Dim objCP As CustomProperty
Dim bolFound As Boolean
bolFound = False 'preset.
For Each objCP In InSheet.CustomProperties
'if this property's name is the one whose value is sought...
If (StrComp(objCP.Name, WithPropertyName, vbTextCompare) = 0) Then
objCP.Value = WithValue
bolFound = True
Exit For
End If
Next
'if the property didn't already exist on the sheet, add it.
If (Not bolFound) Then Call InSheet.CustomProperties.Add(WithPropertyName, WithValue)
End Sub
'Return the value of the custom property with the provided name in the provided sheet.
Private Function GetCustomPropertyValue(InSheet As Worksheet, WithPropertyName As String) As Variant
Dim objCP As CustomProperty
GetCustomPropertyValue = Empty
For Each objCP In InSheet.CustomProperties
'if this property's name is the one whose value is sought...
If (StrComp(objCP.Name, WithPropertyName, vbTextCompare) = 0) Then
GetCustomPropertyValue = objCP.Value
Exit For
End If
Next
End Function
Then you can do something like this to write and read back values:
Sub test()
Dim strPropName As String
strPropName = "MyRange_" & Selection.Address
Dim strWhatIWantToStore As String
strWhatIWantToStore = "Here's what I want to store for this range"
Call SetCustomPropertyValue(ActiveSheet, strPropName, strWhatIWantToStore)
MsgBox GetCustomPropertyValue(ActiveSheet, strPropName)
End Sub