VBA check for value in a range - vba

I am trying to loop through a column and if cells = "what i'm lookng for" then do something.
I have this so far, where I'm off is in the if statement where I check for the "name":
Option Explicit
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For c = 16 To 20
LastRow = .Cells(.Rows.Count, c).End(xlUp).Row
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
name = rngSource.Value
If name = "mark"
do something
End If
Next c
End With
Application.ScreenUpdating = True
'MsgBox "Done!", vbExclamation
End Sub

OK Chris
Maybe a bit of simplification is required but also a few assumptions.
It doesn't seem like LastCol is being used for anything - so let's assume this is the Column you want to loop through.
Your loop has fixed start and end values yet you are determining the LastRow - so let's assume you want to start from row 5 (in your code) and loop to the LastRow in the LastCol.
In order to determine LastCol you must have data in the row you are using to do this - so let's assume that there are values in row 1 in all columns up to column you want to loop say 16 (in your code).
If you want to (IF) test for a single (string) value in this case then you must arrange for your rngSource to be a single cell value. You also don't need to assign this to a variable unless you need to use it again.
Finally, if you want to check for other values you may want to consider using a SELECT CASE structure in place of your IF THEN structure.
Have a look at the following and change my assumptions to meet your requirement - good luck.
Sub test()
Dim wksDest As Worksheet
Dim wksSource As Worksheet
Dim rngSource As Range
Dim name As String
Dim LastRow As Long
Dim LastCol As Long
Dim c As Long
Application.ScreenUpdating = False
Set wksSource = Worksheets("Sheet1")
With wksSource
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(Rows.Count, LastCol).End(xlUp).Row
FirstRow = 5
For c = FirstRow To LastRow
If .Range(.Cells(c, LastCol), .Cells(c, LastCol)).Value = "Mark" Then
MsgBox ("do something")
End If
Next c
End With
End Sub

You can just do that with one line.
If Not IsError(Application.Match(ValueToSearchFor, RangeToSearchIn, 0)) Then
'The value found in the given range
End If
Example:
Search for "Canada" in column C of sheet named "Country"
If Not IsError(Application.Match("Canada", Sheets("Country").Range("C:C"), 0)) Then
'The value found in the given range
End If

Pass value to find and Column where value need to be checked. It will return row num if its found else return 0.
Function checkForValue(FindString As String,ColumnToCheck as String) As Long
SheetLastRow = Sheets("Sheet1").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).row
With Sheets("Sheet1").Range("$" & ColumnToCheck & "$1:$" & ColumnToCheck & "$" & CStr(SheetLastRow) )
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
checkForValue = rng.row 'return row its found
'write code you want.
Else
checkForValue = 0
End If
End With
End Function

I tried Hari's suggestion, but Application.Match works weird on range names (not recognizing them...)
Changed to: WorksheetFunction.Match(...
It works, but when value is not present A runtime ERROR jumps before IsError(...) is evaluated.
So I had to write a simple -no looping- solution:
dim Index as Long
Index = -1
On Error Resume Next
Index = WorksheetFunction.Match(Target,Range("Edificios"), 0) 'look for Target value in range named: Edificios
On Error GoTo 0
If Index > 0 Then
' code for existing value found in Range # Index row
End If
Remeber Excel functions first index = 1 (no zero based)
Hope this helps.

I'm guessing what you really want to do is loop through your range rngSource. So try
Set rngSource = .Range(.Cells(5, 16), .Cells(LastRow, 16))
for myCell in rngSource
if myCell.Value = "mark" then
do something
end if
next myCell

Related

How can I find the last row with a cell containing data vba to set print area?

I know this question may seem nearly identical to past ones, but there's a nuance in my sheet in that one of my columns is completely empty aside from the first 7 rows. The problem being that my code finds the last row in which ALL cells contain data rather than the last row with at least one data item. I.e. A1:Q7 contain data and since all of the rows contain data my code sets the print area to A1:Q7 although there is data in C14. I want my print area to be A1:Q14. How would I go about doing this. Code below.
Sub SetPrintArea()
Dim ALastFundRow As Integer
Dim AFirstBlankRow As Integer
Dim wksSource As Worksheet
Dim ws As Worksheet
Dim rngSheet As Range
Set wksSource = ActiveWorkbook.Sheets("WIRE SCHEDULE")
Set ws = ThisWorkbook.Sheets("WIRE SCHEDULE")
'Finds last row of content
ALastFundRow = wksSource.Range("A8").End(xlDown).Row
'Finds first row without content
AFirstBlankRow = ALastFundRow + 1
Set rngSheet = ws.Range("A1:Q" & LastFundRow + 7)
'Sets PrintArea to the last Column with a value and the last row with a value
ws.PageSetup.PrintArea = rngSheet.Address
End Sub
Anything would help. Thanks!
The function GetLastCell() will find the last row and column containing data
Option Explicit
Public Sub SetPrintArea()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("WIRE SCHEDULE")
ws.PageSetup.PrintArea = ws.Range("A1:" & GetLastCell(ws).Address).Address
End Sub
Public Function GetLastCell(Optional ByVal ws As Worksheet = Nothing) As Range
Dim uRng As Range, uArr As Variant, r As Long, c As Long
Dim ubR As Long, ubC As Long, lRow As Long
If ws Is Nothing Then Set ws = Application.ThisWorkbook.ActiveSheet
Set uRng = ws.UsedRange: uArr = uRng
If IsEmpty(uArr) Then
Set GetLastCell = ws.Cells(1, 1): Exit Function
End If
If Not IsArray(uArr) Then
Set GetLastCell = ws.Cells(uRng.Row, uRng.Column): Exit Function
End If
ubR = UBound(uArr, 1): ubC = UBound(uArr, 2)
For r = ubR To 1 Step -1 '----------------------------------------------- last row
For c = ubC To 1 Step -1
If Not IsError(uArr(r, c)) Then
If Len(Trim$(uArr(r, c))) > 0 Then
lRow = r: Exit For
End If
End If
Next
If lRow > 0 Then Exit For
Next
If lRow = 0 Then lRow = ubR
For c = ubC To 1 Step -1 '----------------------------------------------- last col
For r = lRow To 1 Step -1
If Not IsError(uArr(r, c)) Then
If Len(Trim$(uArr(r, c))) > 0 Then
Set GetLastCell = ws.Cells(lRow + uRng.Row - 1, c + uRng.Column - 1)
Exit Function
End If
End If
Next
Next
End Function
With ActiveSheet 'or whatever worksheet
LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
End With
You can use a similar algorithm for the last column.
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Note that we are looking for xlValues so cells with formulas that return a null string will not be included.
If the worksheet is empty, the code will produce an error; so if that might be a possibility, you should test for that.
Try this code.
.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sub SetPrintArea()
Dim ALastFundRow As Integer
Dim AFirstBlankRow As Integer
Dim wksSource As Worksheet
Dim ws As Worksheet
Dim rngSheet As Range
Set wksSource = ActiveWorkbook.Sheets("WIRE SCHEDULE")
Set ws = ThisWorkbook.Sheets("WIRE SCHEDULE")
'Finds last row of content
'ALastFundRow = wksSource.Range("A8").End(xlDown).Row
ALastFundRow = wksSource.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Finds first row without content
AFirstBlankRow = ALastFundRow + 1
Set rngSheet = ws.Range("A1:Q" & LastFundRow)
'Sets PrintArea to the last Column with a value and the last row with a value
ws.PageSetup.PrintArea = rngSheet.Address
End Sub

VBA Frequency Highlighter Function in Very Large Excel Sheet

In a previous post user: LocEngineer managed to help me to write a finding function that would find the least frequent values in a column of a particular category.
The VBA code works well for the most part with some particular issues, and the previous question had been answered with a sufficiently good answer already, so I thought this required a new post.
LocEngineer: "Holy smoking moly, Batman! If THAT truly is your sheet.... I'd say: forget "UsedRange". That won't work well enough with THAT spread... I've edited the above code using more hardcoded values. Please adapt the values according to your needs and try that. Woah what a mess."
Here is the code:
Sub frequenz()
Dim col As Range, cel As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long, totalRows As Long
Dim relFrequency As Double
Dim RAN As Range
RAN = ActiveSheet.Range("A6:FS126")
totalRows = 120
For Each col In RAN.Columns
'***get column letter***
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
'*******
For Each cel In col.Cells
lookFor = cel.Text
frequency = Application.WorksheetFunction.CountIf(Range(letter & "2:" & letter & totalRows), lookFor)
relFrequency = frequency / totalRows
If relFrequency <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
Next cel
Next col
End Sub
The Code is formatted like this: (Notice the merged cells that head each column for titles. The titles go down to row 5 and data starts on row 5) (Also Notice that the rows are very much filled with empty columns, sometimes more so than data.)
Finally, one important change I cant figure out is how to get it to ignore blank cells.
Please advise. Thank you.
If the 2 adjustments to be made are to 1. exclude headers, and 2. blank cells
Exclude the headers in way a bit more dynamic; this excludes the top 6 rows:
With ActiveSheet.UsedRange
Set ran = .Offset(6, 0).Resize(.Rows.Count - 6, .Columns.Count)
End With
In the inner For loop, after this line For Each cel In col.Cells you need an IF:
For Each cel In col.Cells
If Len(cel.Value2) > 0 Then...
Here is the modified version (untested):
Option Explicit
Sub frequenz()
Const MIN_ROW As Long = 6
Const MAX_ROW As Long = 120
Dim col As Range
Dim cel As Range
Dim rng As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long
With ActiveSheet.UsedRange
Set rng = .Offset(MIN_ROW, 0).Resize(MAX_ROW, GetMaxCell.Column)
End With
For Each col In rng.Columns
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
For Each cel In col
lookFor = cel.Value2
If Len(lookFor) > 0 Then 'process non empty values
frequency = WorksheetFunction.CountIf( _
Range(letter & "2:" & letter & MAX_ROW), lookFor)
If frequency / MAX_ROW <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
End If
Next cel
Next col
End Sub
.
Updated to use a new function when determining the last row and column containing values:
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'It returns the last cell of range with data, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End With
End If
End Function

How to find multiple strings in VBA

Assume an Excel sheet contains the following values in a random column:
VARIABLE X
AbbA
AddA
bbAA
ccbb
KaaC
cccc
ddbb
ccdd
BBaa
ddbB
Bbaa
dbbd
kdep
mCca
mblp
ktxy
Now the column should be searched for several words and word-phrases at the same time, for example the following:
(1) "bb"
(2) "cc"
(3) "d"
I put the target strings in an array:
Dim searchFor As String
Dim xArr
searchFor = "bb/cc/d"
xArr = Split(searchFor , "/")
Also assume it does not matter if "bb" is in small letters or big letters (not case sensitive in this case). For the other cases it is case sensitive.
At the end I would like to select the respective target cases in terms of their associated rows. Please also note that I would like to include cases in the selection, where the target string (e.g. "bb") is part of a word (e.g. "dbbd").
If possible, ignore the column title ("VARIABLE X) for searching/filtering as well as in the final selection of values.
How can this be done in VBA using (1) filters and/or using (2) regular loops? Which way would you recommend?
AbBa should be either selected or deleted. I am trying to ID 'wrong cases' by applying this routine.
Further to my comments, here is an example using .Find and .FindNext
My Assumptions
We are working with Col A in Sheets("Sheet1")
My Array is predefined. You can use your array.
In the below example, I am coloring the cells red. Change as applicable.
Sub Sample()
Dim MyAr(1 To 3) As String
Dim ws As Worksheet
Dim aCell As Range, bCell As Range
Dim i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
MyAr(1) = "bb"
MyAr(2) = "cc"
MyAr(3) = "d"
With ws
'~~> Loop through the array
For i = LBound(MyAr) To UBound(MyAr)
Set aCell = .Columns(1).Find(What:=MyAr(i), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
aCell.Interior.ColorIndex = 3
Do
Set aCell = .Columns(1).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
aCell.Interior.ColorIndex = 3
Else
Exit Do
End If
Loop
End If
Next
End With
End Sub
Start with your data in column A, this:
Sub qwerty()
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To N
t = LCase(Cells(i, 1).Text)
If InStr(t, "bb") + InStr(t, "cc") + InStr(t, "d") = 0 Then
Cells(i, 1).EntireRow.Hidden = True
End If
Next i
End Sub
will hide the miscreants:
AutoFilter can be tough with more than two options.
One way to delete these would be to use the Advanced Filter. Of course, you don't need VBA for this, but using VBA:
Option Explicit
Sub FilterByStrings()
Dim rData As Range
Dim rFiltered As Range
Dim rCriteria As Range
Dim vStrings As Variant, critStrings() As Variant
Dim I As Long
vStrings = VBA.Array("bb", "cc", "d")
Set rData = Range("a1", Cells(Rows.Count, "A").End(xlUp))
Set rFiltered = Range("B1")
Set rCriteria = Range("c1")
'Add the wild cards and the column headers
ReDim critStrings(1 To 2, 1 To UBound(vStrings) + 1)
For I = 0 To UBound(vStrings)
critStrings(1, I + 1) = rData(1, 1)
critStrings(2, I + 1) = "<>*" & vStrings(I) & "*"
Next I
'criteria range
Set rCriteria = rCriteria.Resize(UBound(critStrings, 1), UBound(critStrings, 2))
rCriteria = critStrings
rData.AdvancedFilter Action:=xlFilterCopy, criteriarange:=rCriteria, copytorange:=rFiltered
rCriteria.EntireColumn.Clear
End Sub
If you want to return the cells that match those strings, you would set up the criteria range differently, removing the <> and having the criteria in a single column, rather than in adjacent rows.

Excel VBA - Select a range using variables & COUNTA

Excel VBA - Select a range using variables & COUNTA
Hi Staked VBA Kings & Queens, I'm trying to learn Excel VBA. A simple task I would like to do is select all the contagious cells in a report dump I get from sales. Simple i'm sure, but I am a total beginner at VBA.
Ok Report Info:
The report is a set number of columns (31). Although I would like to build a bit of variability into my code to accommodate a change in column numbers.
The report grows by number of rows each week, some times less, sometimes more. But Always starts at cell [A4].
I though of using COUNTA function to count used number of rows, then set that as a variable. Similar with rows.
This is what I came up with, although I get a "Run-time Error '1004': Method 'Range' of object'_Global failed... can anyone help me out".
For me the key is to learn VBA using task I need getting done. I understand the logic behind my code, but not exactly the write way to write it. If some proposes a totally different code I might get lost.
But I am open minded.
Sub ReportArea()
Dim numofrows As Integer
Dim numofcols As Integer
Dim mylastcell As String
Dim myrange As Range
Worksheets("Sheet1").Select
numofrows = WorksheetFunction.CountA(Range("AE:AE"))
numofcols = WorksheetFunction.CountA(Range("4:4"))
Set myrange = Range(Cells(4, 1), Cells(numofrows, numofcols))
Range(myrange).Select
End Sub
P.S I did try read slimier trends but only got confused as the solution where very involved.
Find last row and last column
Sub Sht1Rng()
Dim ws As Worksheet
Dim numofrows As Long
Dim numofcols As Long
Dim myrange As Range
Set ws = Sheets("Sheet1")
With ws
numofrows = .Cells(.Rows.Count, "AE").End(xlUp).Row
numofcols = .Cells(4, .Columns.Count).End(xlToLeft).Column
Set myrange = .Range(.Cells(4, 1), .Cells(numofrows, numofcols))
End With
MsgBox myrange.Address
End Sub
You can also use this code.
Sub SelectLastCellInInSheet()
Dim Rws As Long, Col As Integer, r As Range, fRng As Range
Set r = Range("A1")
Rws = Cells.Find(what:="*", after:=r, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Col = Cells.Find(what:="*", after:=r, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set fRng = Range(Cells(2, 1), Cells(Rws, Col)) ' range A2 to last cell on sheet
fRng.Select 'or whatever you want to do with the range
End Sub
Further to my above comment, is this what you are trying?
Sub ReportArea()
Dim ws As Worksheet
Dim Lrow As Long
Dim myrange As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Last row of COl AE. Change it to the relevant column
Lrow = .Range("AE" & .Rows.Count).End(xlUp).Row
Set myrange = .Range("A4:AE" & Lrow)
With myrange
'
'~~> Do whatever you want to do with the range
'
End With
End With
End Sub
Note: Also you don't need to select a range/worksheet. Work with objects. Interesting Read
alternative solutions to already posted:
1:
Dim LRow&, LColumn&
Lrow = Sheets("SheetName").Cells.SpecialCells(xlCellTypeLastCell).Row
LColumn = Sheets("SheetName").Cells.SpecialCells(xlCellTypeLastCell).Column
MsgBox "Last Row is: " & Lrow & ", Last Column is: " & LColumn
2:
Dim x As Range
Set x = Range(Split(Sheets("SheetName").UsedRange.Address(0, 0), ":")(1))
MsgBox "Last Row is: " & x.Row & ", Last Column is: " & x.Column
output result

Loop through range, once value is found, copy cell value and everything under and move to next column

This is my first post. I've been trying to teach myself excel VBA and it has been quite challenging.
Anyways I have been working on loops and ranges etc etc.
Here's my dilemma:
Option Explicit
Sub Move_Data()
Dim i As Long
Dim j As Long
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
Dim result As String
result = "New Results"
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 3 To LastRow
For j = 1 To LastColumn
If Cells(i, 1) = result Then
j = j + 1
Cells(i, 1).Copy Destination:=ActiveSheet.Cells(i, j)
End If
Next j
Next i
End Sub
Little by little I have put the above together. Here's my question:
I am trying to look at all the values in column "A". Once "New Results" is found I want to copy not only this cell, but everything underneath it, to a column "J". Then find the string in column "B" and copy the range to column "K", etc.
So far the code finds "New Results" and moves it to column "B" which is expected since is the only code I have written. How can add another loop that will copy everything under "New Results" along with it and move it over to the new column. This way J will keep increasing and eventually I will have all the results broken down by columns.
Hopefully this makes sense.
Thanks all,
You dont have to loop through all the cells. Rather use the Find() method. It's more efficient I think.
Sub Move_Data()
Dim rngFound As Range
Dim intColLoop As Integer
Dim LastColumn As Integer
Dim result As String 'added in edit, forgot that, oops
Dim intColPaste As Integer 'added in edit
result = "New Results"
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
With Cells
'in case the result is not on the ActiveSheet, exit code
If .Find(result) Is Nothing Then Exit Sub
'*****************Search all the columns, find result, copy ranges
'search all the columns
For intColLoop = 1 To LastColumn
With Columns(intColLoop)
'check if the result is in this column
If Not .Find(result) Is Nothing Then
'find the result
Set rngFound = .Find(result)
'copy the found cell and continuous range beneath it to the destination column
Range(rngFound, rngFound.End(xlDown)).Copy Destination:=Cells(Rows.Count, 10 + intColPaste).End(xlUp) 'Edit : changed the "10" to "10 + intColPaste"
intColPaste = intColPaste + 1 'Edit : added counter for columns
End If
End With
Next intColLoop 'proceed to next column
End With
End Sub
Very well written for your first post, congrats!
Option Explicit
Sub Move_Data()
Dim SourceCol As integer
Dim DestCol As Integer
Dim LastRow As Long
'Dim LastColumn As Long
Dim rng As Range
Dim result As String
Dim Addr as string
SourceCol = 1 'Column A
DestCol = 2 'Column B
result = "New Results"
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
While not rng is Nothing and Addr <> rng.Range.Address
'If not rng is Nothing
ActiveSheet.range(cells(rng.row, DestCol),cells(LastRow,DestCol) = _
ActiveSheet.range(cells(rng.row,SourceCol), cells(LastRow,SourceCol))
'End If
Addr = rng.range.address(ReferenceStyle:=xlR1C1)
set rng = ActiveSheet.Range(cells.Address).Find (What:=Result, LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
wend
End Sub
Adjust SourceCol and DestCol as needed.
That's untested and off the top of my head, so it might need a minor tweak. Use .Find() to find your text, then set your destination range = to what you just found.
As written, it will find one occurrence of result. If you have multiple occurrences of result, comment out/delete the If... and 'End If` lines, then uncomment the 4 lines that are commented & they'll loop through, finding them all.