I need to search a worksheet by a particular value in a specific column. I have to do something with values in other columns of the found rows. What is the most simple and efficient way to get all row numbers that have the search value in that specific column?
Thanks.
You could try something like that:
Public Function Test(str As String, rng As Range) As Variant
Dim xVal As Variant, Arr() As Variant
Dim i As Long
ReDim Arr(0 To 100)
For Each xVal In rng
If xVal.Value = str Then
Arr(i) = xVal.Row
i = i + 1
End If
Next
If i Then
ReDim Preserve Arr(0 To i - 1)
Test = Arr
Else
Test = 0
End If
End Function
(Done by phone. May contain errors.)
If you are looking for happiness in some region of a worksheet, the select that region and run:
Sub FindingHappiness()
Dim s As String, rng As Range, r As Range
Dim msg As String
Set rng = Intersect(Selection, ActiveSheet.UsedRange)
s = "happiness"
For Each r In rng
If InStr(1, r.Text, s) > 0 Then
msg = msg & vbCrLf & r.Row
End If
Next r
MsgBox msg
End Sub
Note that using this technique will allow you to search in a single row, or in a single column, or in a block of cells, or all the cells on a worksheet, or even in a disjoint group of cells.
Related
I'm trying to write something up that will search a specific range for specific numbers.
EX:
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
DO THIS
ElseIf InStr(cell.Value, "154") > 0 Then
DO THIS
etc...
I used instr since the cell will have things like "word 1 word 2 260 word 3."
For every match it finds within that range, I want to put a certain value into the same row in a different column.
Suggestions? Thanks in advance!
Try This:
Sub testing()
Dim cell As Range
For Each cell In Range("E5:E112")
If InStr(cell.Value, "260") > 0 Then
cell.Offset(0, 2).Value = "Found 260"
ElseIf InStr(cell.Value, "154") > 0 Then
cell.Offset(0, 2).Value = "Found 154"
End If
Next
End Sub
create an array of the items you want to look up then loop that with a built in lookup function.
Then use the row number returned to find the value you want. It will be quicker
Dim lkupArr()
lkupArr = Array(260, 154)
Dim i As Long
For i = LBound(lkupArr) To UBound(lkupArr)
Dim lkuprow As Long
lkuprow = 0
On Error Resume Next
lkuprow = Application.WorksheetFunction.Match("*" & lkupArr(i) & "*", ActiveSheet.Range("E:E"), 0)
On Error GoTo 0
If lkuprow > 0 Then
MsgBox lkupArr(i) & " found on row " & lkuprow & "."
'Then just use the return to return the value from the column you want
'The following returns the value in column F on the same row.
Dim ret
ret = ActiveSheet.Cells(lkuprow, "F").Value
Debug.Print ret
End If
Next i
Maybe not the most elegant solution, however does not make extensive use of the spreadsheet, so performance wise (if you have a lot of data to process), should be better than other solutions so far.
Function SearchAndFind()
Dim wb As Workbook
Dim ws As Worksheet
Dim rngValues As Range
Dim arrRng As Variant, arrFind As Variant
Dim i As Long, j As Long, newColOffset As Long
'Adjust as needed
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set rngValues = ws.Range("E5:E112")
arrRng = rngValues
arrFind = Array("260", "154")
newColOffset = 2
For i = LBound(arrRng) To UBound(arrRng) 'loop through the given range, first column only
For j = LBound(arrFind) To UBound(arrFind) 'loop through items to find
If InStr(arrRng(i, 1), arrFind(j)) > 0 Then 'found the value
'Return the values
rngValues.Cells(1, 1).Offset(i - 1, newColOffset).Value = arrRng(i, 1)
Exit For
End If
Next j
Next i
End Function
I am trying to create a macro that reads data and does econometrics on the data. At this point I am trying to implement a latent variable MLE estimation.
The data can be of any length, depending on the user input. Suppose there is data in column O and column P. Ex-ante I have no idea how many rows of data exist.
I would like to first read how many data there are and then upload the data into my array variable before I can do any econometrics/statistics on it.
In this problem, the user has 25 data points for each variable. Some other user may enter different data with different number of data points.
In the code below, I am trying to read the variable "D" into an array. I first count the number of non-empty cells and then create an array of that size and try to read the value of the cells into the array. But I am getting a "type mismatch" error.
I've tried both "Variant" and "Array" types. Variant seems to be working but Array is not.
Sub SampleStats()
Dim Rng As String
Dim Var1(1 To 100) As Double
Dim Var2() As Double
Dim Var3 As Variant
Dim NumElements2 As Integer
Dim length2 As Integer
NumElements2 = WorksheetFunction.Count(Range("P:P"))
length2 = NumElements2+1
MsgBox NumElements2
ReDim Var2(1 To NumElements2)
Rng = "P2:P" & length2
MsgBox Rng
Var3 = Range(Rng).Value
MsgBox Var3(1,1)
Var2 = Range(Rng).Value
MsgBox Var2(1,1)
End Sub
My questions are:
Whats the best way to read data when you don't know how long the columns go?
What the best way to store data (Variant or Array or something else) when the final objective is doing some statistics?
First you get the Range with the column of data you want to pass into the array. Second you use the Application.Transpose function on the data and assign it to a Variant to create a 1-dimensional array from the Range.Value property.
If you just assign the range's Value directly to the Variant you will get a 2-dimensional array of N rows x 1 column. Sample code:
Option Explicit
Sub GetRangeToArray()
Dim ws As Worksheet
Dim rngData As Range
Dim varData As Variant
Dim lngCounter As Long
' get worksheet reference
Set ws = ThisWorkbook.Worksheets("Sheet1")
' get the column to analyse - example here is A2:A last row
' so using 1 in column reference to Cells collection
Set rngData = ws.Cells(2, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp))
' convert range from 2d to 1d array
varData = Application.Transpose(rngData.Value)
' test array
For lngCounter = LBound(varData) To UBound(varData)
Debug.Print varData(lngCounter)
Next lngCounter
End Sub
sub createarraywithoutblanks()
creatary ary, Sheets("Table_Types"), "A":
alternative ary:
BuildArrayWithoutBlanks ary
end sub
Sub creatary(ary As Variant, sh As Worksheet, ltr As String)
Dim x, y, rng As range
ReDim ary(0)
Set rng = sh.range(ltr & "2:" & ltr & sh.range("A10000").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
x = 0
For Each y In rng
ary(x) = y
x = x + 1
ReDim Preserve ary(x)
Next y
End Sub
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function
Sub alternative(ary As Variant)
Dim Array_2()
Dim Array_toRemove()
Dim dic As New Scripting.Dictionary
Dim arrItem, x As Long
For Each arrItem In ary
If Not dic.Exists(arrItem) Then
dic.Add arrItem, arrItem
Else
ReDim Preserve Array_toRemove(x)
Array_toRemove(x) = dic.Item(arrItem)
x = x + 1
End If
Next
'For Each arrItem In Array_toRemove
' dic.Remove (arrItem)
'Next arrItem
ary = dic.Keys
End Sub
Sub BuildArrayWithoutBlanks(ary As Variant)
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ary
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If AryFromRange(Counter) <> 0 Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = AryFromRange(Counter)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
ary = AryNoBlanks
End Sub
Hi I have been given a sheet with some formulas in them for example:
=SUM(D4:D1051) - can pretend this is in cells(1,1)
With VBA how can I pull out the row start and row end?
Ideally i would have lRowStart = 4 and lRowEnd = 1051 but I am not sure of the syntax to use to get this.
Something like this
for x = range("a1").Precedents(1).row to range("a1").Precedents(range("a1").Precedents.Count).row
If there are no formula in the range :)
or something along these lines.
Dim strFormula
Dim lngStartRow As Long
Dim lngEndRow As Long
strFormula = Replace(Replace(Cells(1, 1).Formula, "=SUM(", vbNullString), ")", vbNullString)
lngStartRow = Range(Split(strFormula, ":")(0)).Row
lngEndRow = Range(Split(strFormula, ":")(1)).Row
or even extract the range address then use foreach on the range .Rows, just no need for the split to get the range address.
You can get the cells that are referenced in the formula using .Precedents
Dim rng As Range
Dim rowStart As Long
Dim rowEnd As Long
On Error Resume Next 'in case there are no precedents
Set rng = Cells(1, 1).Precedents
On Error GoTo 0
If Not rng Is Nothing Then
rowStart = rng.Row 'or rng.Areas(1).Row (see edit)
rowEnd = rng.Row + rng.Rows.Count - 1 'or rng.Areas(1).Row and rng.Areas(1).Rows.Count
Else
rowStart = 0
rowEnd = 0
End If
Edit there are a few cases that are tricky. If the formula contains multiple references, e.g. =SUM(B1:B2) + SUM(D3:D4) you will get a union of ranges. The same is true if the cells that are referenced have references to other cells themselves.
In these cases, you can use .Areas to get the individual areas the range consists of. I'm not sure how they are ordered exactly but it seems that the "top-level" references are first. Example:
Dim rng As Range
Dim ar As Range
Range("A1").Formula = "=sum(B5:B7) + B1"
Range("B6").Formula = "=B3"
Set rng = Range("A1").Precedents
For Each ar In rng.Areas
Debug.Print ar.Address
Next ar
Output:
$B$5:$B$7
$B$1
$B$3
However be careful as areas will be combined if the are next to each other.
It also seems that it can't handle references to other sheets very well.
I am trying to use the following VBA code to do two things.
Count the number of unique visible rows in a filtered worksheet.
Delete the duplicate rows
So far:
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
R.Delete
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
End Function
This counts okay, and if I replace R.Delete with MsgBox(R.Row) I get the correct row number of the duplicate.
R.Delete does nothing.
R.EntireRow.Delete does nothing
ws.Rows(R.Row).Delete does nothing.
UPDATE
This doesn't seem to be working
Function UniqueVisible(MyRange As Range) As Integer
Dim ws As Worksheet
Set ws = Worksheets(1)
Dim R As Range
Dim Dup As Integer
Dup = 0
Dim Dups() As Integer
ReDim Dups(0 To MyRange.Count) As Integer
Dim V() As String
ReDim V(0 To MyRange.Count) As String
For Each R In MyRange
If (R.EntireRow.Hidden = False) Then
For Index = 0 To UniqueVisible
If (V(Index) = R.Value) Then
Dups(Dup) = R.Row
Dup = Dup + 1
Exit For
End If
If (Index = UniqueVisible) Then
V(UniqueVisible) = R.Value
UniqueVisible = UniqueVisible + 1
End If
Next
End If
Next R
For Each D In Dups
ws.Rows(D).Delete
Next D
End Function
It seems you're breaking a few rules here.
You cannot use a function to delete rows in VBA. It does not matter whether you are using the function as a User Defined Function (aka UDF) on the worksheet or calling it from a sub in a VBA project. A function is meant to return a value, not perform operations that modify the structure (or even the values other than its own cell) on a worksheet. In your case, it could return an array of row numbers to be deleted by a sub.
It is considered canonical practise to start from the bottom (or the right for columns) and work up when deleting rows. Working from the top to the bottom may skip rows when a row is deleted and you loop to the next one.
Here is an example where a sub calls the function to gather the count of the unique, visible entries and an array of rows to be removed.
Sub remove_rows()
Dim v As Long, vDelete_These As Variant, iUnique As Long
Dim ws As Worksheet
Set ws = Worksheets(1)
vDelete_These = UniqueVisible(ws.Range("A1:A20"))
iUnique = vDelete_These(LBound(vDelete_These))
For v = UBound(vDelete_These) To (LBound(vDelete_These) + 1) Step -1 'not that we are working from the bottom up
ws.Rows(vDelete_These(v)).EntireRow.Delete
Next v
Debug.Print "There were " & iUnique & " unique, visible values."
End Sub
Function UniqueVisible(MyRange As Range)
Dim R As Range
Dim uniq As Long
Dim Dups As Variant
Dim v As String
ReDim Dups(1 To 1) 'make room for the unique count
v = ChrW(8203) 'seed out string hash check with the delimiter
For Each R In MyRange
If Not R.EntireRow.Hidden Then
If CBool(InStr(1, v, ChrW(8203) & R.Value & ChrW(8203), vbTextCompare)) Then
ReDim Preserve Dups(1 To UBound(Dups) + 1)
Dups(UBound(Dups)) = R.Row
Else
uniq = uniq + 1
v = v & R.Value & ChrW(8203)
End If
End If
Next R
Dups(LBound(Dups)) = uniq 'stuff the unique count into the primary of the array
UniqueVisible = Dups
End Function
Now, that is probably not how I would go about it. Seems easier to just write the whole thing into a single sub. However, understanding processes and limitations is important so I hope you can work with this.
Note that this does not have any error control. This should be present when dealing with arrays and deleting row in loops.
You can't delete a row while you're looping through the rows. You'll need to store the rows that need to be deleted in an array, and then loop through the array and delete the rows after it's done looping through the rows.
I want to count no of different cells which are selected using VBA.
Consider if we select five distinct cells - D5, C2, E7, A4, B1.
Is there a way I can count these number of cells.
Secondly how can I retrieve data in these cells. Lets say I want to store it in an array.
Thank you for the help.
Dim rngCell as Range, arrArray() as Variant, i as integer
Redim arrArray(1 to Selection.Cells.Count)
i = 1
For each rngCell in Selection
arrArray(i) = rngCell.Value
i = i + 1
Next
Looks like you got it mostly figured out, but here is something to load it into an array if you want it:
Public Sub Example()
Dim test() As Variant
test = RangeToArray(Excel.Selection, True)
MsgBox Join(test, vbNewLine)
End Sub
Public Function RangeToArray(ByVal rng As Excel.Range, Optional ByVal skipBlank As Boolean = False) As Variant()
Dim rtnVal() As Variant
Dim i As Long, cll As Excel.Range
ReDim rtnVal(rng.Cells.Count - 1)
If skipBlank Then
For Each cll In rng.Cells
If LenB(cll.Value) Then
rtnVal(i) = cll.Value
i = i + 1
End If
Next
ReDim Preserve rtnVal(i - 1)
Else
For Each cll In rng.Cells
rtnVal(i) = cll.Value
i = i + 1
Next
End If
RangeToArray = rtnVal
End Function
Thankfully I got a way around it by doing - Selection.Cells.Count
It returns me the cell count for selected cells.
But I am still stuck with dynamically assigning this value to an array as in ---
I = Selection.Cells.Count Dim ValArr(I)