I am looking at various options in VBA to find out the row number in a worksheet that has filter enabled.
If ThisWorkbook.Sheets(1).AutoFilterMode = True Then
The above line checks only if the sheet contains filters, but I need to know which row number has the filters on.
This should do your job.
Sub test()
Dim rngRange As range
If ThisWorkbook.Sheets(1).AutoFilterMode = True Then
Set rngRange = ThisWorkbook.Sheets(1).AutoFilter.range
MsgBox "Address of Filter: " & rngRange.Address & Chr(10) _
& "Row Number is: " & rngRange.Row, vbOKOnly
End If
Set rngRange = Nothing
End Sub
This is a straight answer to your question:
Function CheckWhichRowHasFilter(r As range)
For Each rowi In r.Rows' Dim rowi As range
Set pa = rowi.Parent.AutoFilter'Dim pa As AutoFilter
If pa.FilterMode = True Then
CheckWhichRowHasFilter = pa.range.Address
Exit For
End If
Next rowi
End Function
This is how to iterate through Filters. The Property you want to check is Filter.On
Sub IterateThroughFilters()
Dim r As range
Set r = Selection
Dim rc As range
For Each rc In r.Columns
If Not rc.Parent.AutoFilter Is Nothing Then
Set currentColumnFilter = rc.Parent.AutoFilter ' Filteraddress: = currentColumnFilter.range.Address
Dim ccf As filters
Set ccf = currentColumnFilter.filters
Dim cf1 As filter
Set cf1 = ccf(1) 'onebased index
If cf1.On Then 'Here you check if filter is on
cfc1 = cf1.Criteria1(1)
cfc2 = cf1.Criteria1(2)
cfc3 = cf1.Criteria1(3)
End If
End If
Next rc
End Sub
Related
I have a live report in Excel that shows if cranes are currently delayed. What I would like to do, by using VBA, is to make it so that when a crane either starts a delay, or ends one, the file will go from being minimized to being expanded so that a user can be signalled for when a crane has gone on delay. I would also like this to only occur for the cranes that are present within the table after being filtered.
I have attached an image of the data along with the relevant filter for cranes.
Crane Delay Data with Crane Filter
My thinking was to scan the Grand Total column, and if the value has changed from being empty to having a figure greater than 0 (and vice versa) to trigger a Macro that will make the file visible.
If possible, what code would I need to use and how would I go about doing this?
Many thanks.
For those interested, I have come up with a solution. Please leave a comment if you want me to talk through it. Code is below:
Option Explicit
Private Sub Worksheet_PivotTableAfterValueChange(ByVal TargetPivotTable As PivotTable, ByVal TargetRange As Range)
End Sub
Public Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
Dim pt As PivotTable
Dim wsBackup As Worksheet
Dim c As Range
Dim rngPivot As Range
Dim lastCol As Long
Dim strCrane As String
Dim sValues As Variant
sValues = ArrayListOfSelectedAndVisibleSlicerItems("Slicer_QC1")
'Change to suit
Set pt = Me.PivotTables("PivotTable1")
'Where has a copy of table been saved?
Set wsBackup = ThisWorkbook.Worksheets("Pivot Copy")
Set rngPivot = pt.DataBodyRange
'How many columns?
lastCol = rngPivot.Columns.Count
Application.ScreenUpdating = False
'Check each cell in last column/grand total
For Each c In rngPivot.Columns(lastCol).Cells
'What item is this?
strCrane = c.Offset(0, -lastCol).Value
'Escape clause
If strCrane = "Grand Total" Then Exit For
If c.Value = 0 Then
'Use a function that won't throw an error
'Note we add 1 to account for row labels
If WorksheetFunction.SumIfs(wsBackup.Columns(1 + lastCol), _
wsBackup.Range("A:A"), strCrane) <> 0 Then
If IsInArray(strCrane, sValues) = True Then
ActiveWindow.WindowState = xlMaximized
MsgBox strCrane & " has ended a delay" & vbCrLf & vbCrLf & "(Minimise Excel after using file)"
End If
End If
ElseIf c.Value > 0 Then
If WorksheetFunction.SumIfs(wsBackup.Columns(1 + lastCol), _
wsBackup.Range("A:A"), strCrane) = 0 Then
If IsInArray(strCrane, sValues) = True Then
ActiveWindow.WindowState = xlMaximized
MsgBox strCrane & " has started a delay" & vbCrLf & vbCrLf & "(Minimise Excel after using file)"
End If
End If
End If
Next c
'Save our new backup
wsBackup.Cells.Clear
pt.TableRange2.Copy
wsBackup.Range("A1").PasteSpecial xlPasteValues
'Clean up
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Function ArrayListOfSelectedAndVisibleSlicerItems(MySlicerName As String) As Variant
'This function returns an array of the limited set of items in Slicer A
'Limitation is due to both:
'(1) direct selection of items by user in slicer A
'(2) selection of items in slicer B which in consequence limits the number of items in slicer A
Dim ShortList() As Variant
Dim i As Integer: i = 0 'for iterate
Dim sC As SlicerCache
Dim sI As SlicerItem 'for iterate
Set sC = ThisWorkbook.SlicerCaches(MySlicerName)
For Each sI In sC.SlicerItems
If sI.Selected = True Then
' Debug.Print sI.Name
ReDim Preserve ShortList(i)
ShortList(i) = sI.Value
i = i + 1
End If
Next sI
ArrayListOfSelectedAndVisibleSlicerItems = ShortList
End Function
Private Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = UBound(Filter(arr, stringToBeFound)) > -1
End Function
Jim L from Ontario was a tremendous help in solving my first challenge. You can review that at this link : Previous Discussion
I thought it would be a simple matter to add filters for additional columns once the DATE FILTER QUESTION was solved. Nope.
I've tried adding additional filters within the same confines as the DATE filter ... I've tried adding the additional filters in the same sub but below the DATE filter ... even placing the additional filters in separate subs. Nothing is working.
The example workbook may be downloaded here : Download Workbook
The end users will have a need to filter on one or more columns at the same time. How can I work that in with the existing code in the workbook ?
I'm stumped !
Thanks.
Try adding the auto-filter across all the columns and then use each button to set the criteria for one column only. Here is an example for the fist 3 columns that you can expand to the others.
COL_FILTER is an integer parameter to the sub filterCol which is generic to all the columns you want to add a filter to (except the date which is a special case). Assign your "UNIT" filter button to the sub FilterB, "Call RCVD" button to sub FilterC etc. When you first press any button the filter drop downs appear across all columns but only 1 column will have criteria applied. Pressing further buttons will set criteria for those additional columns and retain the previous filters. Entering a blank search term will remove the criteria for that column only
Option Explicit
Sub ResetFilters()
Dim Wks As Worksheet
Set Wks = Sheets("Call Log File")
With Wks
On Error Resume Next
If Wks.AutoFilterMode Then
Wks.AutoFilterMode = False
End If
End With
End Sub
Sub FilterB()
Call filterCol(2)
End Sub
Sub FilterC()
Call filterCol(3)
End Sub
Sub filterCol(COL_FILTER As Integer)
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Call Log File")
' set auto filter to all columns if not already on
Dim rngFilter As Range
Set rngFilter = ws.Range("A2:K2")
If ws.AutoFilterMode = False Then
rngFilter.AutoFilter
End If
'Debug.Print rngFilter.Address
' get filter criteria
Dim sColname As String
sColname = ws.Cells(2, COL_FILTER)
Dim sPrompt As String, sUserInput As String, n As Integer
sPrompt = "Enter " & sColname
sUserInput = InputBox$(sPrompt)
Dim criteria(2) As String
criteria(1) = "*" & sUserInput & "*"
' apply filter to the select column
If ws.AutoFilterMode = True Then
rngFilter.AutoFilter COL_FILTER, "=" & criteria(1)
End If
End Sub
Sub FilterDate()
Const COL_FILTER As Integer = 1 ' A
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Call Log File")
' set auto filter to all columns if not already on
Dim rngFilter As Range
Set rngFilter = ws.Range("A2:K2")
If ws.AutoFilterMode = False Then
rngFilter.AutoFilter
End If
'Debug.Print rngFilter.Address
Dim sPrompt As String, sUserInput As String, n As Integer
sPrompt = "Enter DATE" & vbCrLf & _
"For YEAR ONLY: YY" & vbCrLf & _
"For YEAR & MONTH: YYMM" & vbCrLf & _
"For YEAR & MONTH & DAY: YYMMDD"
sUserInput = InputBox$(sPrompt)
n = Len(sUserInput)
If n = 0 Then
rngFilter.AutoFilter COL_FILTER ' clear filter
Exit Sub
ElseIf Not (n = 2 Or n = 4 Or n = 6) Then
MsgBox sUserInput & " is not correct", vbExclamation, "Wrong Format"
Exit Sub
End If
Dim mydate As Variant
mydate = dateRange(sUserInput)
'Debug.Print sUserInput, mydate(1), mydate(2)
If ws.AutoFilterMode = True Then
rngFilter.AutoFilter COL_FILTER, ">=" & mydate(1), 1, "<=" & mydate(2)
End If
End Sub
Function dateRange(s As String)
Dim s1 As String, s2 As String
s1 = "000"
s2 = "999"
Select Case Len(s)
Case 2
s1 = "0101" & s1
s2 = "1231" & s2
Case 4
s1 = "01" & s1
s2 = "31" & s2
Case 6
' nothing to add
Case Else
dateRange = ""
Exit Function
End Select
Dim rng(2) As Long
rng(1) = CLng(s + s1)
rng(2) = CLng(s + s2)
dateRange = rng
End Function
Fo the benefit of others ... this following macro will search for a term in Col B, after the table was filtered by Col A. Although this is not a "filtering approach" in Col B, it is very effective and does precisely what I was looking for.
Thank you to all for your assistance.
Sub FilterB()
Dim cl As Range, rng As Range
Dim sPrompt As String, sUserInput As String
Set rng = Range("B3:B100")
sPrompt = "Enter SEARCH TERM"
sUserInput = InputBox$(sPrompt)
For Each cl In rng.SpecialCells(xlCellTypeVisible)
If cl.Value <> sUserInput Then
cl.Rows.Hidden = True
End If
Next cl
End Sub
And this can be duplicated as many times as required to further "filter down" additional columns.
In my Sheet 1, Column A has some values and I need to create a Active X checkbox for all the values in Sheet 2 in a specific cell. First I need to check whether Active X checkbox is there for the value or not, If its not there, I need to create. I already tried the below code, But its creating the duplicate checkboxes.
Sub Addcheckbox()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=183, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
rr = rr + 1
Next cell
End Sub
How to check whether ActiveX checkbox already present in the sheet or not with Caption name
i tried this code for checking the checkboxes.. But its not working..
Function shapeExists(ByRef shapename As String) As Boolean
shapeExists = False
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If sh.name = shapename Then
shapeExists = True
Exit Function
End If
Next sh
End Function
ActiveX Checkboxes are OleObjects. Is this what you are trying?
Also you need to specify the correct .Top else they will be created at the same place. See how I used Top:=cell.Top
Sub Sample()
Dim rng As Range, cell As Range
Dim rr As Integer
Dim tf As Boolean
Dim shpTemp As Shape
Set rng = Range("A1:A8")
Set Destrng = Range("A2:A9")
rr = 2
For Each cell In Worksheets("Sheet1").Range("A1:A8")
If Not IsEmpty(cell.Value) Then
If Not CBExists(cell.Value) Then '<~~ Check if the checkbox exists
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=51.75, Top:=cell.Top, Width:=120, Height:=19.5)
.Object.Caption = cell.Value
End With
End If
End If
rr = rr + 1
Next cell
End Sub
'~~> Function to check if the checkbox exists
Function CBExists(s As String) As Boolean
Dim oleObj As OLEObject
Dim i As Long
For i = 1 To Worksheets("Sheet1").OLEObjects.Count
If s = Worksheets("Sheet1").OLEObjects(i).Object.Caption Then
CBExists = True
Exit Function
End If
Next i
End Function
I have a column range of about 500 rows. Most of those cells are stored as text. I populate a listbox on a userform with the values from that range. When a user selects one of those values from the listbox an event will find the value on the same row from another column using Index and Match and display it in a label on the userform. I get an error when selecting one of the few cells in the listbox that are not stored as text in the range because there is a leading space. I am assuming that the populated listbox automatically removes leading spaces from any cells in the range. Therefore, when it tries to find value 12345 from the listbox, for example, in the range it can't find it because the range contains (space)12345. I have tried:
Public Sub UserForm_Initialize()
Dim arr() As Variant
Dim rNum As Range
Const sNum As String = "Number"
Me.EnableEvents = False
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pReport
If .AutoFilterMode = True Then .ShowAllData
.Cells.Rows.Hidden = False
.Cells.Columns.Hidden = False
End With
Set wf = Application.WorksheetFunction
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
End With
-- HERE is where I tried all my implementations without success
arr = wf.Transpose(pReport.Range(rNum.address).Value)
Call BubbleSort(arr)
frmIssues.lstIssues1.List = arr
lstIssues1.ListStyle = 1
lstIssues2.ListStyle = 1
lstIssues1.MultiSelect = 2
lstIssues2.MultiSelect = 2
txtFocus.SetFocus
Me.EnableEvents = True
End Sub
Private Sub lstIssues1_Change()
Dim rNum As Range
Dim rTitle As Range
Dim strResult As String
Dim intIndex As Integer
Dim intCount As Integer
Const sNum As String = "Number"
Const sTitle As String = "Title"
If EnableEvents = False Then Exit Sub
With lstIssues1
For intIndex = 0 To .ListCount - 1
If .Selected(intIndex) Then intCount = intCount + 1
Next
End With
If intCount = 1 Then
Set wf = Application.WorksheetFunction
wsName = "Report"
Set curWb = ActiveWorkbook
Set pReport = curWb.Worksheets(wsName)
Set pTable = pReport.ListObjects("tableName")
With pTable
Set rNum = .ListColumns(.ListColumns(sNum).Range.column).DataBodyRange
Set rTitle = .ListColumns(.ListColumns(sTitle).Range.column).DataBodyRange
End With
With pReport
strResult = wf.Index(.Range(rTitle.address), wf.Match(lstIssues1.List(lstIssues1.ListIndex), .Range(rNum.address), 0))
End With
lblDescription.Caption = wf.Trim(strResult)
txtFocus.SetFocus
Else
lblDescription.Caption = ""
txtFocus.SetFocus
Exit Sub
End If
Me.EnableEvents = False
For i = 0 To lstIssues2.ListCount - 1
If lstIssues2.Selected(i) = True Then lstIssues2.Selected(i) = False
Next
Me.EnableEvents = True
End Sub
and numerous variations of it (Clean, CStr, .Text, etc.) and nothing works. Truly, I have no clue how to fix this and any help whatsoever is much appreciated. Thank you!
Clarification
1) This Excel file is generated from the Web.
2) A Macro turns the Worksheet into a table
3) Left(Range("D362"),1) returns 1 (The number, say, is 12345)
4) Before the error occurs Range("D362") returns (space)12345
5) After the error occurs Range("D362") returns (space)12345
I have just tested this and it works in removing the space at the begining of a string. Sadly it isnt a single line as I (and likely you) would have prefered
Sub test()
Dim CellValue As String
Dim lngNumberOfCharacters As Long
CellValue = ActiveCell.Value
CellValueCheck = Left(CellValue, 1)
If CellValueCheck = " " Then
lngNumberOfCharacters = Len(CellValue) - 1
CellValue = Right(CellValue, lngNumberOfCharacters)
ActiveCell.Value = CellValue
End If
End Sub
Let me know if you need anything confirmed
Sub CheckBox7_Click()
Dim cBox As CheckBox
Dim LRow As Integer
Dim LRange As String
LName = Application.Caller
Set cBox = ActiveSheet.CheckBoxes(LName)
'Find row that checkbox resides in
LRow = cBox.TopLeftCell.Row
LRange = "B" & CStr(LRow)
'Change text in column b, if checkbox is checked
If cBox.Value > 0 Then
ActiveSheet.Range(LRange).Value = "3300-0401"
'Clear text in column b, if checkbox is unchecked
Else
ActiveSheet.Range(LRange).Value = Null
End If
End Sub
I need value 3300-0401 to be entered in the first available cell beginning at b15 through b40. Also, where would this date be entered in the string?
Thanks, Jean
You can use the following to write to the first blank cell in the range B15:B40:
Sub WriteToFirstAvailableCellInRange()
Dim wb As Workbook
Dim ws As Worksheet
Dim firstEmptyCell As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
If ws.Range("B15").Value = "" Then
Set firstEmptyCell = ws.Range("B15")
Else
If ws.Range("B16").Value = "" Then
Set firstEmptyCell = ws.Range("B16")
Else
Set firstEmptyCell = ws.Range("B15").End(xlDown).Offset(1)
End If
End If
If firstEmptyCell.Row < 41 Then
firstEmptyCell.Value = "3300-0401"
Else
MsgBox "There aren't any empty cells in range B15:B40."
End If
End Sub