How to bypass code if criteria don't match? - excel

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
'...
'...

Related

VBA cannot AutoFilter a Range for a certain criteria

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

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

Excel VBA Hiding Rows

In the picture below, I'm trying to hide the rows that are empty in a certain cells (e.g. Row 39 to Row 48). Is is possible to do it in one click? I'm planning of doing it with VBA.
This is the formula that I'm currently using but the thing is the cells that I want to hide may not start at row 39 or ends at row 48, it depends on the data.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
'ws.Rows("39:48").Hidden = True
Next
End Sub
Hide 'Empty' Rows
This is a slightly different approach:
uses Option Explicit
uses constants and variables
uses For Each...Next loops for both, worksheets and cells
qualifies all objects (e.g. ws.Cells or rg.Cells, not just Cells)
combines empty cells into a range
unhides all rows in one go, then hides the 'empty' rows in another (go)
Option Explicit
Sub HideRows()
Const StartRow As Long = 9
Const EndRow As Long = 89
Const ColNum As Long = 3
Dim WorksheetNames As Variant
WorksheetNames = Array("NAMES", "AUGUST") ' add more
Dim ws As Worksheet ' Current Worksheet
Dim rg As Range ' Current Range
Dim hrg As Range ' Current Hide Range
Dim cCell As Range ' Current Cell in Range
' Loop through the worksheets in the workbook containing this code.
For Each ws In ThisWorkbook.Worksheets(WorksheetNames)
' Create a reference to the range of the current worksheet.
Set rg = ws.Range(ws.Cells(StartRow, ColNum), ws.Cells(EndRow, ColNum))
' or using resize:
'Set rg = ws.Cells(StartRow, ColNum).Resize(EndRow - StartRow + 1)
' Loop through the cells of the current range.
For Each cCell In rg.Cells
If IsEmpty(cCell) Then ' cell is empty
' Combine ('add') the current cell into the hide range.
If Not hrg Is Nothing Then ' for all except the first
Set hrg = Union(hrg, cCell)
Else ' for the first
Set hrg = cCell
End If
'Else ' cell is not empty - do nothing
End If
Next cCell
' Unhide all rows of the current range of the current worksheet.
rg.EntireRow.Hidden = False
If Not hrg Is Nothing Then ' there are combined cells
' Hide the rows of the hide range.
hrg.EntireRow.Hidden = True
' Reset the hide range variable for the next worksheet.
' Also, note that 'Union' works only with ranges from one worksheet.
Set hrg = Nothing
'Else ' there are no combined cells - do nothing
End If
Next ws
End Sub
I already made it. Below is the script that I used.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
StartRow = 9
EndRow = 89
ColNum = 3
For i = StartRow To EndRow
If Not IsEmpty(Cells(i, ColNum).Value) Then
ws.Cells(i, ColNum).EntireRow.Hidden = False
Else
ws.Cells(i, ColNum).EntireRow.Hidden = True
End If
Next i
Next
End Sub

Finding blank cells and moving row

I am trying to find people who are missing their street address and moving their row to a separate tab in my sheet.
Sub NEW_NoAddress()
Const Title As String = "Move Data Rows"
Const scCol As Long = 6
Const dCol As Long = 1
Const Criteria As String = "ISEmpty()"
' Remove any previous filters.
If Sheet1.AutoFilterMode Then
Sheet1.AutoFilterMode = False
End If
' Filter.
Dim srg As Range ' Source Range (Headers and Data)
Set srg = Sheet1.Range("A1").CurrentRegion
srg.AutoFilter scCol, Criteria
' Count the number of matches.
Dim sdrg As Range ' Source Data Range (Without Headers)
Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
Dim sdccrg As Range ' Source Data Criteria Column Range
Set sdccrg = sdrg.Columns(scCol)
Dim drCount As Long ' Destination Rows Count (Matches Count)
drCount = Application.Subtotal(103, sdccrg)
' Move if there are matches.
If drCount > 0 Then ' matches found
Dim sdfrrg As Range ' Source Data Filtered Rows Range
Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
Dim dCell As Range ' Destination Cell
Set dCell = Sheet10.Cells(Sheet10.Rows.Count, dCol).End(xlUp).Offset(1, 0)
With sdfrrg
.Copy dCell
' Either delete the entire worksheet rows...
'.EntireColumn.Delete
' ... or remove filter to prevent...
Sheet1.AutoFilterMode = False
' ... deleting the entire worksheet rows leaving possible data
' to the right (after the empty column) intact.
.Delete xlShiftUp
End With
Else ' no matches
Sheet1.AutoFilterMode = False
End If
End Sub
I tried "<>", "<> **", " "" ", I think I tried one that had vbStringISNull, (), and other things I came across in Google. I considered going the other direction and keeping the <> to move those who have an address, but I'd rather move the incorrect entries to my exceptions tab.
Move Matching Rows
I'm glad you like my code. Unfortunately, it has a big mistake:
drCount = Application.Subtotal(103, sdccrg)
which is similar to Excel's ACOUNT which results in 0 when selecting blanks.
I've seen this in a couple of codes and adopted it as valid. Was I in for a surprise.
When you plan on using such a code so intensely, you want to move the changing variables to the arguments section to easily use it many times (see the long procedure below).
You can use the new procedure...
... for your first question like this:
Sub MoveMatchRows()
MoveMatchingRows Sheet1, 4, "FD.Matching Gifts FY22", Sheet2, 1, False
End Sub
... for yesterday's question like this:
Sub NEW_Move_Stock_InKind_DAF()
MoveMatchingRows Sheet1, 44, "<>*/*", Sheet8, 1, False
End Sub
... and for today's question like this:
Sub NewNoAddress()
MoveMatchingRows Sheet1, 6, "=", Sheet10, 1, False
End Sub
I have declared SourceCriteria as variant and added xlFilterValues to be able to use multiple criteria, e.g. Array("1", "2").
The Procedure
Sub MoveMatchingRows( _
ByVal SourceWorksheet As Worksheet, _
ByVal SourceColumn As Long, _
ByVal SourceCriteria As Variant, _
ByVal DestinationWorksheet As Worksheet, _
Optional ByVal DestinationColumn As Long = 1, _
Optional ByVal DoClearPreviousDestinationData As Boolean = False)
Const ProcTitle As String = "Move Matching Rows"
' Remove any previous filters.
If SourceWorksheet.AutoFilterMode Then
SourceWorksheet.AutoFilterMode = False
End If
' Filter.
Dim srg As Range ' Source Range (Headers and Data)
Set srg = SourceWorksheet.Range("A1").CurrentRegion
srg.AutoFilter SourceColumn, SourceCriteria, xlFilterValues
' Create a reference to the Source Data Range (no headers).
Dim sdrg As Range
Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
' Clear Destination worksheet.
If DoClearPreviousDestinationData Then ' new data, copies headers
DestinationWorksheet.Cells.Clear
End If
' Attempt to create a reference to the Source Data Filtered Rows Range.
Dim sdfrrg As Range
On Error Resume Next
Set sdfrrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not sdfrrg Is Nothing Then
' Create a reference to the Destination Cell (also, add headers).
Dim dCell As Range ' Destination Cell
Set dCell = DestinationWorksheet.Cells(1, DestinationColumn)
If IsEmpty(dCell) Then
srg.Rows(1).Copy dCell
Set dCell = dCell.Offset(1)
Else
Set dCell = DestinationWorksheet.Cells( _
DestinationWorksheet.Rows.Count, DestinationColumn) _
.End(xlUp).Offset(1, 0)
End If
With sdfrrg
.Copy dCell
' Either delete the entire worksheet rows...
'.EntireColumn.Delete
' ... or remove filter to prevent...
SourceWorksheet.AutoFilterMode = False
' ... deleting the entire worksheet rows leaving possible data
' to the right (after the empty column) intact.
.Delete xlShiftUp
End With
Else ' no matches
SourceWorksheet.AutoFilterMode = False
End If
End Sub

How to paste data into next empty cell to the right?

I want to copy data from sheet1 to sheet2, row number 9 with one condition. The data should be inserted to the next empty cell to the right.
I wrote a procedure that is a bit more general than #FahmiYogyas question.
Assume the source range is a named range of one or more cells (here NamedRange1) and the top left cell of the destination is a second named range (here NamedRange2).
Option Explicit
'
' start this as example
'
Sub test1()
copyData Range("NamedRange1"), Range("NamedRange2")
End Sub
'
'
'
Sub copyData(sourceRange As Range, destinationRange As Range)
Dim myCell As Range
Dim columnOffset As Long
Dim firstCell As Range
Dim isFirst As Boolean
'
' increase the column offset until the first destination cell is empty
'
Do While Not IsEmpty(destinationRange.Offset(0, columnOffset))
columnOffset = columnOffset + 1
Loop
isFirst = True
'
' now get the value of the source cells
' and insert it at the destination position
' offset is used to allow for arbitrary source ranges
For Each myCell In sourceRange
If isFirst Then
Set firstCell = myCell
isFirst = False
End If
destinationRange.Offset(myCell.Row - firstCell.Row, myCell.Column - firstCell.Column + columnOffset).Value = myCell.Value
Next
End Sub

Resources