How do I add another filter criteria?
So that I can filter by date (like it does) and if comboBox1 value = to what is in column A for each row
The other one I have is filter by date (like it does) and if there is a value in column H for each row
Private Sub CommandButton1_Click()
Dim strStart As String, strEnd As String, strPromptMessage As String
If TextBox1.Value = "" Then
TextBox1.Value = Date
End If
If TextBox2.Value = "" Then
TextBox2.Value = Date
End If
'Prompt the user to input the start date
strStart = TextBox1.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = TextBox2.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorksheet(strStart, strEnd)
Unload Me
End Sub
Public Sub CreateSubsetWorksheet(StartDate As String, EndDate As String)
Dim wksData As Worksheet, wksTarget As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
Set wksData = ThisWorkbook.Worksheets("CopyDatabase")
lngDateCol = 5 '<~ we know dates are in column E
'Identify the full data range on Sheet1 (our data sheet) by finding
'the last row and last column
lngLastRow = LastOccupiedRowNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
lngLastCol = LastOccupiedColNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
With wksData
Set rngFull = .Range(.Cells(3, 1), .Cells(lngLastRow, lngLastCol))
End With
'Apply a filter to the full range we just assigned to get rows
'that are in-between the start and end dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'If the resulting range contains only 1 row, that means we filtered
'everything out! Check for this situation, catch it and exit
If wksData.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "Oops! Those dates filter out all data!"
'Clear the autofilter safely and exit sub
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
Exit Sub
Else '<~ otherwise we're all good!
'Assign ONLY the visible cells, which are in the
'date range specified
Set rngResult = .SpecialCells(xlCellTypeVisible)
'clear contents
ThisWorkbook.Sheets("Reports").Range("A3:A" & Range("A3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("B3:B" & Range("B3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("C3:C" & Range("C3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("D3:D" & Range("D3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("E3:E" & Range("E3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("F3:F" & Range("F3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("G3:G" & Range("G3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("H3:H" & Range("H3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("I3:I" & Range("I3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("J3:J" & Range("J3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("K3:K" & Range("K3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("L3:L" & Range("L3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("M3:M" & Range("M3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("N3:N" & Range("N3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("O3:O" & Range("O3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("P3:P" & Range("P3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("Q3:Q" & Range("Q3").End(xlDown).Row).ClearContents
'Create a new Worksheet to copy our data to and set up
'a target Range (for super easy copy / paste)
Set wksTarget = ThisWorkbook.Sheets("Reports")
Set rngTarget = wksTarget.Cells(2, 1)
rngResult.Copy Destination:=rngTarget
End If
End With
'Clear the autofilter safely
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
'Holler at the user, our macro is done!
MsgBox "Data transferred!"
End Sub
Related
I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub
I'm trying to filter the ID in a table, using IDs from another list. However, when I try to do so the macro only filters the first value in the list.
Table Format
Code:
Sub Test()
Dim wb As Workbook
Set wb = ThisWorkbook
ActiveSheet.AutoFilterMode = False
Workbooks.Open "C:\List.xlsx"
Criteria = Worksheets("DataArray").Range("A3:A103")
wb.Activate
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Criteria, Operator:=xlFilterValues
End Sub
The "List" is in another workbook so I need the macro to open it first.
When I try changing the Range to A4:A103 the filter will just use the A4 (first value in the range).
Try the next way, please:
Dim Crit As Variant
Set Crit = Worksheets("DataArray").Range("A3:A103").Value
ActiveSheet.Range("$A$8:$BE$5000").AutoFilter Field:=3, Criteria1:=Application.Transpose(Crit), Operator:=xlFilterValues
The column list must be transposed on a row. Otherwise, only its first element will be used.
You can do all this by selecting the ranges (directly in the Excel interface). The following code is reusable:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range containing filtering values!" _
& vbNewLine & "Please select a single continuous range!" _
& vbNewLine & vbNewLine & "Note that by selecting a single cell, your" _
& " selection will default to the current region for that cell!" _
, "Select Range")
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim arrValues() As Variant: arrValues = rngSecond.Value2
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
ReDim arrCriteria(0 To rngSecond.Count - 1)
i = 0
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
If rng.Cells.Count = 1 Then Set rng = rng.CurrentRegion
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Cells.Count = 1 Then
If MsgBox("No region found from selected cell" & vbNewLine _
& "Please select more than 1 cell!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
ElseIf rng.Rows.Count = 1 Then
If MsgBox("Please select more than 1 row!", vbQuestion _
+ vbRetryCancel, "Cancelled") <> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function
Just run the FilterBySelection method
EDIT 1
Or, if you would like to have less restrictions and be able to select multiple ranges for the filtering values then use this instead:
Option Explicit
Public Sub FilterBySelection()
Dim rngFirst As Range
Dim rngSecond As Range
'
'Get Ranges from User Selection
Set rngFirst = GetRangeBySelection("Select range to filter!" _
& vbNewLine & "Please select a single continuous range!" _
, "Select Range", False)
If rngFirst Is Nothing Then Exit Sub
'
Set rngSecond = GetRangeBySelection("Select range(s) containing filtering values!" _
, "Select Range", True)
If rngSecond Is Nothing Then Exit Sub
'
'Filter first range using values from the second range
Dim rng As Range
Dim arrValues() As Variant
Dim arrCriteria() As Variant
Dim i As Long
Dim v As Variant
'
'Criteria values must be a 1-dimension array
i = 0
ReDim arrCriteria(0 To rngSecond.Count - 1)
For Each rng In rngSecond.Areas
If rng.Count = 1 Then
ReDim arrValues(0 To 0)
arrValues(0) = rng.Value2
Else
arrValues = rng.Value2
End If
For Each v In arrValues
arrCriteria(i) = CStr(v) 'Criteria must be string data type
i = i + 1
Next v
Next
'
'Filter
On Error Resume Next
If rngFirst.ListObject Is Nothing Then
rngFirst.AutoFilter
rngFirst.AutoFilter Field:=1, Criteria1:=arrCriteria, Operator:=xlFilterValues
Else
With rngFirst.ListObject.Range
.AutoFilter Field:=rngFirst.Column - .Column + 1 _
, Criteria1:=arrCriteria, Operator:=xlFilterValues
End With
End If
On Error GoTo 0
End Sub
Public Function GetRangeBySelection(ByVal prompt_ As String, ByVal title_ As String _
, allowMultiArea As Boolean) As Range
Dim rng As Range
'
Do While rng Is Nothing
On Error Resume Next
Set rng = Application.InputBox(Prompt:=prompt_, Title:=title_, Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Function
'
On Error GoTo ErrorHandler
If rng.Areas.Count > 1 And Not allowMultiArea Then
If MsgBox("Your selection contains " & rng.Areas.Count _
& " different ranges!" & vbNewLine & "Please select only 1 " _
& "range!", vbQuestion + vbRetryCancel, "Cancelled") _
<> vbRetry Then Exit Function
Set rng = Nothing
End If
Loop
Set GetRangeBySelection = rng
Exit Function
ErrorHandler:
MsgBox "Try selecting a smaller range next time", vbInformation, "Cancelled"
End Function
I am trying to print a few months worth of time sheets. So print 20 copies of the same sheet, and change the date on one cell (cell "C1" on "Timesheets" sheet) using a list of fortnightly dates on the "Pay Periods" sheet.
Have tried multiple methods but can't get close for varying reasons...
Would be interested to learn why am getting errors or stuck on each method I have tried below.
Sub PrintAllDates()
Dim printDate As Date
Dim startDate As Date
Dim endDate As Date
startDate = Worksheets("Pay Periods").Range("A2")
endDate = Worksheets("Pay Periods").Range("A10")
For printDate = startDate To endDate
Sheets("Timesheet").Range("C1") = printDate
Sheets("Timesheet").PrintOut
Next
This works but I can't figure out how to get it to use the list.
It prints out 9 consecutive days instead, whereas my list is 9 consecutive "fortnights".
Sub PrintCopies()
Dim i As Integer
Dim VList As Variant
VList = Sheets("Pay Periods").Range("H2:H3").Value
For i = LBound(VList) To UBound(VList)
Range("C1") = VList(i)
ActiveSheet.PrintOut
Next
With the above, I get runtime error 9 "Subscript out of range" on Range("C1") = VList(i)
Sub PrintCopies()
Dim i As Date
Dim VList As Variant
VList = Array(Worksheets("Pay Periods").Range("A2:A10"))
For i = LBound(VList) To UBound(VList)
Sheets("Timesheet").Range("C1") = VList(i)
Sheets("Timesheet").PrintOut
Next
This also works, but only 1 page gets printed out.
Date also gets converted to "13 Jan 1900".
The first code does not work because it is not considering the whole range of dates; instead it takes only the value inside the first and last cell, treating them as dates. The code basically takes those dates and covers each day between them. It does not even akwnoledge the others cells between A2 and A10. This one should work:
Sub PrintAllDates()
'Declaring variables.
Dim RngDate As Range
Dim RngDates As Range
Dim RngTarget As Range
'Setting variables.
Set RngDates = Sheets("Pay Periods").Range("A2:A10")
Set RngTarget = Sheets("Timesheet").Range("C1")
'Covering each cell in RngDates.
For Each RngDate In RngDates
'Changing RngTarget.
RngTarget = RngDate.Value
'Printing RngTarget's sheet.
RngTarget.Parent.PrintOut
Next
End Sub
I've also added a feature to check if the given value is a date in this version:
Sub PrintAllDates()
'Declaring variables.
Dim RngDate As Range
Dim RngDates As Range
Dim RngTarget As Range
'Setting variables.
Set RngDates = Sheets("Pay Periods").Range("A2:A10")
Set RngTarget = Sheets("Timesheet").Range("C1")
'Covering each cell in RngDates.
For Each RngDate In RngDates
'Checking if RngDate does not contain a date value.
If Not VBA.Information.IsDate(RngDate.Value) Then
'Asking what to do in case RngDate does not contain a date value.
Select Case MsgBox("Range " & RngDate.Address(False, False) & " in sheet " & RngDate.Parent.Name & " contains the value """ & RngDate.Value & """, which is a non-date value." & vbCrLf & _
vbCrLf & _
vbCrLf & _
"Do you wish to use it and print anyway?" & vbCrLf & _
vbCrLf & _
"Press ""Yes"" to print it anyway." & vbCrLf & _
vbCrLf & _
"Press ""No"" to not print it and proceed to the next value." & vbCrLf & _
vbCrLf & _
"Press ""Cancel"" to stop the macro and print no more.", _
vbYesNoCancel, _
"Non-date value detected" _
)
'If "Cancel" is pressed, the macro is terminated.
Case Is = 2
Exit Sub
'If "Yes" is pressed, the macro goes on.
Case Is = 6
'If "No" is pressed, the macro goes to NextRngDate
Case Is = 7
GoTo NextRngDate
End Select
End If
'Changing RngTarget.
RngTarget = RngDate.Value
'Printing RngTarget's sheet.
RngTarget.Parent.PrintOut
'Checkpoint.
NextRngDate:
Next
End Sub
Your code can be something like this:
Sub PrintAllDates()
Dim listRange As Range ' Your range A2:A10 in "Pay Periods" sheet '
Dim oCurrentCell As Range ' Single cell from this range '
Dim printedSheet As Worksheet ' Target sheet - "Timesheet" '
Dim oTargetCell As Range ' C1 - target cell (to set next date from list) '
Set listRange = Worksheets("Pay Periods").Range("A2:A10")
Set printedSheet = Worksheets("Timesheet")
Set oTargetCell = printedSheet.Range("C1")
For Each oCurrentCell In listRange.Cells
oTargetCell = oCurrentCell
Rem If some cells in "Timesheet" has formulas which reffered to C1,
Rem we need recalc it before printing
printedSheet.Calculate
printedSheet.PrintOut
Next oCurrentCell
End Sub
I have one Excel sheet with 6000 rows. I need to delete entire rows if distinct values are less than, say, three in one particular column.
Per below example:
In column-A with the list of colours and in column-B with names.
If I filter any 'name in column-B and in column-A, if less than three distinct values = true then entire row should be deleted.
Rows with name- Chary should be deleted.
A B
Color Employee
Red Dev
blue Dev
blue Dev
Red Dev
black Dev
Red Dev
Red Chary
blue Chary
blue Chary
Red Chary
Red Chary
Red Chary
With my code:
First I filter name in column-B then paste the filtered data new workbook and there I will remove duplicates from column-A then will get the unique count.
If the unique count is less than 3 then activate the main sheet and will delete filtered rows and loop to next name.
Sub Del_lessthan_5folois()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
t = Now()
Set wb = ActiveWorkbook
Sheets("VALID ARNS").Activate
iCol = 2 '### criteria column
Set ws = Sheets("VALID ARNS")
Sheets("VALID ARNS").Activate
Set rnglast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rnglast).SpecialCells(xlCellTypeVisible)
Workbooks.Add
Set newb = ActiveWorkbook
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
newb.Activate
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
Application.CutCopyMode = False
Cells.EntireColumn.AutoFit
Dim uniq As Range
Set uniq = Range("A1:S" & Range("A" & Rows.Count).End(xlUp).Row)
uniq.RemoveDuplicates Columns:=7, Header:=xlYes
LastRow = ActiveSheet.UsedRange.Rows.Count
Cells.Delete Shift:=xlUp
Range("A1").Select
wb.Activate
If LastRow < "3" Then
ActiveSheet.AutoFilter.Range.Offset(1,0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
End If
End If
Next
ws.ShowAllData
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My code works in step by step debug mode but when run it skips a lot of rows.
Can this be related to more than 6000 rows?
How do I get the count of distinct values in Column-A when filtered in Column-B?
It's not exactly the same code that you posted as I had some troubles with it, but here's an alternative solution. I simply copy the data into another sheet (please add sheet called "Results" before you run my code), add two more columns with formulas (these will check if a given "Employee" should be deleted), filter on "TRUE" and then delete relevant rows.
From what I tested such solution seems to be faster than applying Advanced Filters, checking for unique values and then looping through the whole dataset. I hope it will work fine for your setup.
Here's the code:
Sub DeleteRows()
Dim t As Variant
Dim iCol As Long, lngLastRow As Long
Dim wsOrig As Worksheet, wsNew As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
t = Now()
Set wsOrig = Sheets("VALID ARNS")
Set wsNew = Sheets("Results")
iCol = 2 '### criteria column
With wsOrig
lngLastRow = .Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious).Row
'copy into Results sheet
.Range("A1:B" & lngLastRow).Copy wsNew.Range("A1")
With wsNew
'add formulas
.Range("C1:D1").Value = VBA.Array("Instance", "Delete?")
.Range("C2:C" & lngLastRow).Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2)"
.Range("D2:D" & lngLastRow).Formula = "=SUMIFS($C$2:$C$" & lngLastRow & ",$B$2:$B$" & lngLastRow & ",B2,$C$2:$C$" & lngLastRow & ",1)<3"
'delete when column D = TRUE
.Range("A1:D" & lngLastRow).AutoFilter Field:=4, Criteria1:="TRUE"
.Range("D2:D" & lngLastRow).SpecialCells(xlCellTypeVisible).Rows.Delete
'clear
.Range("A1:B" & lngLastRow).AutoFilter
.Range("C:D").Clear
End With
End With
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
"VALID ARNS" sheet:
"Results" sheet (after running the code):
Edit:
Another option, using Scripting.Dictionary functionality:
Public Function getUnique(ByVal rngVals As Excel.Range) As Variant()
Dim objDictionary As Object
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strKey As String
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each rngRow In rngVals.Rows
For Each rngCell In rngRow.Cells
strKey = strKey & "||" & rngCell.Text
Next rngCell
With objDictionary
If Not .Exists(Key:=Mid$(strKey, 3)) Then
Call .Add(Key:=Mid$(strKey, 3), Item:=Mid$(strKey, 3))
End If
End With
strKey = ""
Next rngRow
getUnique = objDictionary.Keys
Set rngVals = Nothing
Set rngRow = Nothing
Set rngCell = Nothing
End Function
Public Sub CountUnique()
Dim rngVals As Excel.Range
Dim varUnique() As Variant
Dim rngCell As Excel.Range
Dim varTemp As Variant
Set rngVals = Sheet3.Range("A2:B13").SpecialCells(12)
varUnique = getUnique(rngVals)
For Each rngCell In rngVals.Columns(2).Cells
varTemp = Filter(varUnique, rngCell.Text, True)
Debug.Print rngCell.Text, UBound(varTemp) - LBound(varTemp) + 1
Erase varTemp
Next rngCell
Set rngVals = Nothing
Set rngCell = Nothing
Erase varUnique
End Sub
I have an excel file of tasks which have either been completed or not, indicated by a Yes or No in a column. Ultimately I am interested in data in a different column but I want to set up the code so it ignores those rows where the task has been completed. So far I have defined the column range containing the yes/no's but I don't know which command to run on this range. I imagine I want to define a new range based on the value in column C.
Option Explicit
Sub Notify()
Dim Chk As Range
Dim ChkLRow As Long
Dim WS1 As Worksheet
On Error GoTo WhatWentWrong
Application.ScreenUpdating = False
'--> If the text in column C is Yes then Ignore (CountIF ?)
'--> Find last cell in the column, set column C range as "Chk"
Set WS1 = Sheets("2011")
With WS1
ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row
Set Chk = .Range("C1:C" & ChkLRow)
End With
'--> Else Check date in column H
'--> Count days from that date until today
'--> Display list in Message Box
Reenter:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
WhatWentWrong:
MsgBox Err.Description
Resume Reenter
Application.ScreenUpdating = True
End Sub
Would it perhaps be easier to simply define one range based on the values in column C rather than first defining column C as the range and then redefining it?
Thanks
Yes Column H has the date the task 'arrived' and I want to display a count from then to the current date. The tasks are identified by a 4 digit code in Column A. I envisage the message box saying Task '1234' outstanding for xx days. – Alistair Weir 1 min ago
Is this what you are trying? Added Col I for visualization purpose. It holds no significance otherwise.
Option Explicit
Sub Notify()
Dim WS1 As Worksheet
Dim Chk As Range, FltrdRange As Range, aCell As Range
Dim ChkLRow As Long
Dim msg As String
On Error GoTo WhatWentWrong
Application.ScreenUpdating = False
Set WS1 = Sheets("2011")
With WS1
ChkLRow = .Range("C" & Rows.Count).End(xlUp).Row
'~~> Set your relevant range here
Set Chk = .Range("A1:H" & ChkLRow)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
With Chk
'~~> Filter,
.AutoFilter Field:=3, Criteria1:="NO"
'~~> Offset(to exclude headers)
Set FltrdRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
For Each aCell In FltrdRange
If aCell.Column = 8 And _
Len(Trim(.Range("A" & aCell.Row).Value)) <> 0 And _
Len(Trim(aCell.Value)) <> 0 Then
msg = msg & vbNewLine & _
"Task " & .Range("A" & aCell.Row).Value & _
" outstanding for " & _
DateDiff("d", aCell.Value, Date) & "days."
End If
Next
End With
End With
'~~> Show message
MsgBox msg
Reenter:
Application.ScreenUpdating = True
Exit Sub
WhatWentWrong:
MsgBox Err.Description
Resume Reenter
End Sub
SNAPSHOT
Why not brute force it.
Dim r_table as Range, i as Integer, N as Integer
' Start from the top
Set r_table = Sheets("2011").Range("C1")
' Find the last entry on column C and count the # of cells
N = Sheets("2011").Range(r_table, r_table.End(xlDown)).Rows.Count
Dim table_values() as Variant
' This will transfer all the values from the spreadsheet into an VBA array
' and it works super fast. Access values with A(row,col) notation.
table_values = r_table.Resize(N, 5).Value2 ' No. of columns is 5 ?
For i=1 to N
If table_values(i,1)="Yes" Then 'Check Column C
Else
... table_values(i,5) ' Column H
End if
Next i
MsgBox ....
This will be super fast, with no flicker on the screen.