VBA cannot AutoFilter a Range for a certain criteria - excel

I am trying to make a Range object of all entrys and than apply a filter, which searches for a number in there.
I want the Range to hold only the matching entrys afterwards, but I always get the error 1004...
Here the code:
Dim rSearch As Range
Dim rResult As Range
Set rSearch = wbMe.Sheets(iCurSheet).Range("F2:F1000")
rSearch.AutoFilter Field:=iColKey, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
The last line throws the exception. I found out that the AutoFilter has to be applied to the first line, so .Range("A1:K1"), but I still don't get why I am not able to Filter on a Range, maybe i get the Object wrong?
Thanks in advance!
Edit:
So I tried some stuff:
Set rSearch = wbMe.Sheets(iCurSheet).Range("A2:K1000")
rSearch.AutoFilter Field:=11, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
MsgBox "Count Rows rSearch:" & rSearch.Rows.Count
I expected the MsgBox to say smth less, but I get 999, so it hasn't filtered anything.
My guess that I was filtering the wrong column, but I wanna filter on Col K (I need Col F afterwards to search once more, sry for mixing stuff up).
Now I don't get the AutoFilter exception anymore. But for some reason my rSearch range does not shrink.
How do I shrink my Range?

Count Visible Data Cells (Criteria Cells)
A quick fix could be something like
MsgBox "Count Rows rSearch:" & rSearch.Columns(11).SpecialCells(xlCellTypeVisible).Cells.Count - 1
Note that the headers need to be included in the range for AutoFilter to work correctly.
Using SpecialCells
Sub CountVisibleDataCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria'). AutoFilter 'prefers' this.
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' Filter the range.
rg.AutoFilter Field:=CriteriaIndex, Criteria1:=Criteria
' Reference the visible cells in the criteria column ('vrg').
Dim vrg As Range
Set vrg = rg.Columns(CriteriaIndex).SpecialCells(xlCellTypeVisible)
' Turn off the worksheet auto filter.
ws.AutoFilterMode = False
' Store the number of visible cells of the criteria column
' in a long variable (subtract 1 to not count the header).
Dim CriteriaCount As Long: CriteriaCount = vrg.Cells.Count - 1
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub
Using Application Count
Sub CountCriteriaCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria').
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' You may need to modify this because 'CountIf' works differently.
' Reference the criteria data range ('cdrg') (no headers).
Dim cdrg As Range
With rg.Columns(CriteriaIndex)
Set cdrg = .Resize(.Rows.Count - 1).Offset(1)
End With
' Store the number of cells containing the criteria ('CriteriaCount')
' in a long variable.
Dim CriteriaCount As Long
CriteriaCount = Application.CountIf(cdrg, Criteria)
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub

Related

Excel - VBA to convert formulas to values on a sheet with an applied autofilter

Is there any way to efficiently convert all formulas on a sheet to values when there is an autofilter applied to the sheet?
I've explored saving the autofilter parameters, unfiltering to paste values, then refiltering using the saved parameters.. found some code that works but that is far too risky (and evidently only works with basic filtering logic used)
Would love to avoid a "for each cell" if possible, as some reports on sheets can be rather lengthy
Convert Formulas in Filter Worksheet To Values
Option Explicit
Sub FilteredToValues()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1") ' adjust!
Dim srg As Range: Set srg = sws.UsedRange
If Not sws.FilterMode Then ' the worksheet is not in filter mode
srg.Value = srg.Value ' or whatever
Exit Sub
End If
' When the worksheet is in filter mode, that means that at least
' one row is hidden. It also means that at least one row, the header row,
' is visible. Thus no error handling is necessary.
Dim arg As Range
' Convert the visible range.
' Reference the visible rows.
Dim vrg As Range: Set vrg = srg.SpecialCells(xlCellTypeVisible)
' Convert by looping through the areas of the visible range.
For Each arg In vrg.Areas
arg.Value = arg.Value
Next arg
' Convert the hidden range.
' Reference the visible cells in the first column.
Dim vcrg As Range: Set vcrg = Intersect(srg.Columns(1), vrg)
Dim urg As Range, cel As Range
' Combine the hidden cells of the first column into a range.
For Each cel In srg.Columns(1).Cells
If Intersect(cel, vcrg) Is Nothing Then
If urg Is Nothing Then Set urg = cel Else Set urg = Union(urg, cel)
End If
Next cel
' Reference the hidden rows.
Dim hrg As Range: Set hrg = Intersect(urg.EntireRow, srg)
' Convert by looping through the areas of the hidden range.
For Each arg In hrg.Areas
arg.Value = arg.Value
Next arg
MsgBox "Formulas converted to values.", vbInformation
End Sub

Select each of 'filtered' values in a column of Sheet 1 and find their occurences in all values of a column in Sheet 2

I have an Excel worksheet comprised of two sheets.
One (Sheet 1) with a list of products, their respective serial numbers and a part number for a specific part - the users enters one or more serial numbers to filter the complete big list to end up with a smaller list of items
One seperate sheet (Sheet 2) that has only one column, a list of part numbers that need to be replaced
Now I want to write a VBA script that on Worksheet_Calculate() (not reflected below) compares the filtered values of a specific column in Sheet 1 (the column containing the part numbers) with the list/column in Sheet 2 and shows a message box for each product containing a part with a number found in the list of sheet2
But I'm having trouble finding a solution for collecting all filtered cells in Sheet 1
I assume I have to somehow make use of the ListObjects property to collect the specific visible/filtered cells and to compare only those to the list in sheet 2
But I don't really know how to select those specific, auto-filtered, cells or write an iteration that accounts for only those cells but still compares to all rows in the list/column of sheet 2
Right now, despite making use of col1 and col2 as ranges with the 'SpecialCells(xlCellTypeVisible)' attribute it always selects all cells of col1
I'm surprised that this selector
prod1 = Cells(r, col1.Column).Value
despite using col1 (which is a limited range) iterates all values, not just the filtered ones
Sub CompareTwoColumns()
Dim col1 As Range, col2 As Range, prod1 As String, lr As Long
Dim incol1 As Variant, incol2 As Variant, r As Long
Set col1 = ActiveSheet.ListObjects("Tabel1").ListColumns.DataBodyRange.SpecialCells(xlCellTypeVisible)
Set col2 = Worksheets("Tabel2").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
lr = Worksheets("Tabel1").UsedRange.Rows.Count
Dim cell As Range
For r = 2 To lr
prod1 = Cells(r, col1.Column).Value
If prod1 <> "" Then
Set incol2 = col2.Find(prod1, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If incol2 Is Nothing Then
MsgBox CStr(prod1) + " Not in List"
Else
MsgBox CStr(prod1) + " Is in List!"
End If
End If
Next r
End Sub
Anyone able to nudge me in the right direction?
Match Value in Range
Adjust the worksheet, table, and column names.
Option Explicit
Sub ComparePartNumbers()
' Often you loop through the cells of the destination worksheet
' and try to find a match in the source worksheet (read, copy from)
' and then in another column of the destination worksheet you write
' e.g. Yes or No (write, copy to).
' The analogy doesn't quite apply in this case but I used it anyway.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet2")
Dim sTbl As ListObject: Set sTbl = sws.ListObjects("Table2")
Dim sLc As ListColumn: Set sLc = sTbl.ListColumns("Part Number")
Dim srg As Range: Set srg = sLc.DataBodyRange
' Attempt to reference the destination range ('drg').
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
Dim dTbl As ListObject: Set dTbl = dws.ListObjects("Table1")
Dim dLc As ListColumn: Set dLc = dTbl.ListColumns("Part Number")
Dim drg As Range
On Error Resume Next
Set drg = dLc.DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Validate the destination range.
If drg Is Nothing Then ' no visible cells
MsgBox "No filtered values.", vbCritical
Exit Sub
'Else ' there are visible cells; do nothing i.e. continue
End If
' Declare additional variables.
Dim dCell As Range ' current destination cell
Dim dPartNumber As String ' current part number read from the cell
Dim sIndex As Variant ' the n-th cell where the value was found or an error
' Loop.
For Each dCell In drg.Cells
dPartNumber = CStr(dCell.Value)
If Len(dPartNumber) > 0 Then ' is not blank
sIndex = Application.Match(dPartNumber, srg, 0)
If IsNumeric(sIndex) Then ' is a match
'MsgBox "'" & dPartNumber & "' is in list!", vbInformation
Debug.Print "'" & dPartNumber & "' is in list!"
Else ' is not a match (VBA: 'Error 2042' = Excel: '#N/A')
'MsgBox "'" & dPartNumber & "' is not in list!", vbExclamation
Debug.Print "'" & dPartNumber & "' is not in list!"
End If
'Else ' is blank; do nothing
End If
Next dCell
End Sub

How to change a value in a Excel table based on a value found through the match function?

I want to change a value in a table based on an array of values.
These values are found through the application.match function.
Dim i As Integer
For i = 16 To 29
If ThisWorkbook.Sheets("General").Range("A" & i) = "" Then
Else
MsgBox ThisWorkbook.Sheets("General").Range("A" & i)
'Find value in Table
Dim Assignments As Worksheet
Dim TargetTable As ListObject
Dim TargetRW As Variant
Set Opdrachten = ThisWorkbook.Sheets("Jobs")
Set TargetTable = Opdrachten.ListObjects("Assignments")
TargetRW = Application.Match(i, TargetTable.ListColumns(1), 0)
MsgBox TargetRW 'I get an error at this point'
'Change value in Table
If Not IsError(TargetRW) Then
TargetTable.DataBodyRange.Cells(TargetRW, 6) = "Yes"
Else
MsgBox "Error, allready verified."
End If
End If
Next i
A VBA Lookup in an Excel Table
Tips
When writing to the same rows of cells of a column range, you usually want to loop through its cells, lookup the values in another column range and write to the same rows in another column, not the other way around.
A type mismatch error will occur if you try to return an error in a message box. You could use an if statement to check if the value is an error and then use CStr to return its string representation, e.g.:
If IsError(TargetRW) Then MsgBox CStr(TargetRW) Else MsgBox TargetRW
I've opted for the shorter IIf version of the same in the code.
Of course, you could also just do:
MsgBox CStr(TargetRW)
since the number is converted to a string anyways.
TargetTable.ListColumns(1) is a ListColumn object. To reference its range with the header or without it, you need to use either TargetTable.ListColumns(1).Range
or TargetTable.ListColumns(1).DataBodyRange (in this particular case) respectively.
The Code
Option Explicit
Sub LookupJobs()
' Source (read, compare)
Const swsName As String = "General"
Const sRangeAddress As String = "A16:A29"
' Destination (loop, compare, write)
Const dwsName As String = "Jobs"
Const dtblName As String = "Assignments"
Const dlcLookupIndex As Long = 1
Const dlcValueIndex As Long = 6
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Reference the source worksheet and the source column range.
Dim sws As Worksheet: Set sws = wb.Worksheets(swsName)
Dim srg As Range: Set srg = sws.Range(sRangeAddress)
' Reference the destination worksheet, table,
' lookup column range (compare) and value column range (write).
Dim dws As Worksheet: Set dws = wb.Worksheets(dwsName)
Dim dtbl As ListObject: Set dtbl = dws.ListObjects(dtblName)
Dim dlrg As Range: Set dlrg = dtbl.ListColumns(dlcLookupIndex).DataBodyRange
Dim dvrg As Range: Set dvrg = dtbl.ListColumns(dlcValueIndex).DataBodyRange
Dim srIndex As Variant ' current index of match in source range or error
Dim dlCell As Range ' current cell of the destination lookup range
Dim dValue As Variant ' value of the current cell
Dim drIndex As Long ' index of the current cell
For Each dlCell In dlrg.Cells
drIndex = drIndex + 1
dValue = dlCell.Value
If Not IsError(dValue) Then ' the cell contains an error value
If Len(dValue) > 0 Then ' the cell is not blank
srIndex = Application.Match(dValue, srg, 0)
'MsgBox IIf(IsError(srIndex), CStr(srIndex), srIndex)
If IsNumeric(srIndex) Then ' match found; write
dvrg.Cells(drIndex).Value = "Yes"
Else ' match not found
'MsgBox "Error, allready verified."
End If
'Else ' the cell is blank; do nothing
End If
'Else ' the cell contains an error value; do nothing
End If
Next dlCell
' Inform.
MsgBox "Jobs lookup finished.", vbInformation
End Sub

How to bypass code if criteria don't match?

The code works when the criteria exists. I get an error when the criteria doesn't exist.
' Define constants.
Const srcName As String = "wfm_rawdata"
Const srcFirst As String = "D2" ' Location for Group
Const dstName As String = "bond_insurance"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
'This function will transfer rows from one worksheet to another worksheet
' if the value = specified critiera
' Define workbook.
Dim wb As Workbook: Set wb = ActiveWorkbook ' Workbook containing this code.
' Define Source Range
Dim LastRow As Long
Dim srg As Range
' Define worksheet and column am working on and
' getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Combine' critical cells into a range.
Dim brg As Range ' Built Range --> Range in the new sheet
Dim cel As Range ' Current Cell Range --> Range in the current sheet(rawdata)
'for every cell in group within wfm_rawdata sheet if the value = GO
For Each cel In srg.Cells
If cel.Value = "BOND INSURANCE" Then
' If the range in the new sheet have nothing then
' add specific criteria from the group in wfm_rawdata
If brg Is Nothing Then
Set brg = cel
' if there is range in there combine the new and
' old range together using -> Union function
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
How can I use a Boolean or other function to bypass the above code if the criteria doesn't exist?
For example if criteria "dog" exists then run the code and if it doesn't exist bypass the code.
I use this code to run three modules with code similar to the top code.
Sub master()
Call report1
Call report2
Call report3
End Sub
One you've assigned srg you can use Match() to check whether it contains any instances of the term you're interested in:
'...
'...
' Define worksheet and column am working on and getting the range of last used cell using(LastRow)
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1, 10)
End With
'Exit if "BOND INSURANCE" is not found in `srg`
If IsError(Application.Match("BOND INSURANCE", srg, 0)) Then Exit Sub
'...
'...

Assigning range of cells results in Type Mismatch (Run-time Error 13)

I am trying to automate the population of a Vlookup formula, looking up values from one worksheet in another. There are two worksheets in the workbook, Suppliers and Products. The product code is looked up from the Products worksheet in the Suppliers worksheet.
This is the code:
Dim lastrow As Long
Sheets("Suppliers").Select
lastrow = ActiveSheet.UsedRange.Rows.Count
Dim SuppliersRnge As Range
Set SuppliersRnge = Range(Cells(2, 2), Cells(lastrow, 3))
' This next try was by declaring the first and last rows and columns in Suppliers sheet as variables and passing values to them (passing values not shown here)
' Set SuppliersRnge = .Range(.Cells(SupplierFirstRow, SupplierFirstColumn), .Cells(SupplierLastRow, SupplierLastColumn))
' This next try was by declaring the range as a static set of cells rather than using lastrow
' Set SuppliersRnge = Range("B2:C23")
' This next try was to pick cell references from currently active worksheet
' Set SuppliersRnge = .Range(.Cells(2, 2), .Cells(lastrow, 3))
' This next try was by fully qualifying the name of the worksheet from which the cell reference is drawn
' Set SuppliersRnge = Worksheets(Suppliers).Range(Cells(2, 2), Cells(lastrow, 3))
' Now switching to product sheet
Sheets("Products").Select
' Selecting cell in which vlookup will be added
Range("A4").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],SuppliersRnge,2,FALSE)"
I am declaring SuppliersRnge as a range and using Set to pass to it the range of cells that need to be looked up.
I have tried to do it in five different ways (you will find four of the ways commented out above) with the same result, which is that the string SuppliersRnge literally gets used in the vlookup, resulting in a >#NAME? value where the result of the Vlookup should be.
When I run ?SuppliersRnge in the Immediate window, I get the Type Mismatch (Run-time Error 13).
If I run a Watch on the SuppliersRnge variable, it starts with a "Nothing" value then changes to a blank.
Any idea on where I might be going wrong? Thanks!
Formulas in VBA
Note the single quotes (around the worksheet name) which are only necessary if the worksheet name contains spaces, but it is good practice to use them always.
Option Explicit
Sub writeVLookupFormula()
Const sName As String = "Suppliers" ' Source
Const dName As String = "Products" ' Destination
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sLast As Long: sLast = sws.UsedRange.Rows.Count
Dim srg As Range: Set srg = sws.Range(sws.Cells(2, 2), sws.Cells(sLast, 3))
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' R1C1-style
Dim dFormula As String: dFormula = "=VLOOKUP(RC[1],'" & sName & "'!" _
& srg.Address(, , xlR1C1) & ",2,FALSE)"
dws.Range("A4").FormulaR1C1 = dFormula
' Or:
' ' A1-style
' Dim dFormula As String: dFormula = "=VLOOKUP(B4,'" & sName & "'!" _
' & srg.Address & ",2,FALSE)"
' dws.Range("A4").Formula = dFormula
End Sub

Resources