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)
Related
I'm looking to work out how many rows a user has selected to be displayed at the top of the sheet next to an action button, I.e. Button says "Generate Email" and next to it says "x items selected".
As this is updated everytime the selection is changed, I have the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = Target.Rows.Count & " items selected"
End Sub
This works fine if the user selects consecutive rows, for e.g. 7:10 returns 4.
My problem is if a user selected rows 7, and 10. It would only return 1 (the rows in the first part of the selection).
From what I've found, there is no way of just getting this value from a property, but I can't get my head around how to iterate through all parts of the selection/target and calculate the sum of rows. Then there is also the possibility that the user selects say A7, C7, and A10. A7 and C7 relate to the same item, so this should only really be treated as one, not two, which I think my hypothetical code would do...
Has anyone tried to achieve this before and been successful or could point me in the direction of some properties which may help? I tried a separate function to achieve it, but that wasn't working either.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Sheet1.Range("E1") = getRowCount(Target) & " items selected"
End Sub
Function getRowCount(selectedRanges As Ranges)
rowCount = 0
For Each subRange In selectedRanges
rowCount = rowCount + subRange.Rows.Count
Next
getRowCount = rowCount
End Function
I think this will work. (Did when I tried it.)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Create a range containing just column A
Dim subRange As Range
Dim r As Range
For Each subRange In Target.Areas
If r Is Nothing Then
Set r = subRange.EntireRow.Columns(1)
Else
Set r = Union(r, subRange.EntireRow.Columns(1))
End If
Next
'Count how many cells in the combined column A range
Sheet1.Range("E1") = r.Cells.Count & " items selected"
End Sub
You need to count the rows in each Area the user has selected.
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-areas-property-excel
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rArea As Range
Dim lCount As Long
For Each rArea In Selection.Areas
lCount = lCount + rArea.Rows.Count
Next rArea
Sheet1.Range("E1") = lCount
End Sub
Sub NumberOfRowsSelected()
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In Selection.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
MsgBox UBound(aRows)
End Sub
Revised Code Converted as Function
Sub NumberOfRowsSelected()
MsgBox RowsCount(Selection)
End Sub
Function RowsCount(rRange As Range) As Long
Dim vMatch As Variant, aRows() As Long, r As Range, x As Long
ReDim Preserve aRows(x)
aRows(x) = 0
For Each r In rRange.Cells
vMatch = Application.Match(r.Row, aRows, 0)
If IsError(vMatch) Then
x = x + 1
ReDim Preserve aRows(0 To x)
aRows(x) = r.Row
End If
Next r
RowsCount = UBound(aRows)
End Function
A different method, building up a string of checked rows seems pretty straight-forward to avoid double counting. See comments for details:
Function getRowCount(rng As Range) As Long
Dim c As Range
' Keep track of which rows we've already counted
Dim countedrows As String: countedrows = ","
' Loop over cells in range
For Each c In rng
' Check if already counted
If Not InStr(countedrows, "," & c.Row & ",") > 0 Then
' Add to counted list
countedrows = countedrows & c.Row & ","
End If
Next c
' Get number of rows counted
Dim rowsarr() As String: rowsarr = Split(countedrows, ",")
getRowCount = UBound(rowsarr) - LBound(rowsarr) - 1
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cell As Range
Dim i, currentRow As Long: i = 0
'get row of first cell in range
currentRow = Target.Cells(1, 1).row
For Each cell In Target
'if row is different, then increase number of items, as it's next item
If Not currentRow = cell.row Then
i = i + 1
currentRow = cell.row
End If
Next cell
Range("E1").Value = i
End Sub
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
I need to get unique values from a range, in a specific cell.
A1=x, A2=y, A3=z, A4=x
I want to get B1=x,y,z
My solution is:
concatenate A1,A2,A3,A4, in B2.
split B2.
make new collection from splitted B2.
output collection elements into C1, C2, ..Ci
concatenate C1, C2,..Ci into B1
Is possible to avoid to output collection into C1,C2 ? but output directly into B1 through some variable ?
'''''''
concatenation part
''''''''
Dim ary As Variant
Dim Arr As New Collection, a
Dim i As Long
ary = split(Range("b2"), ",")
For Each a In ary
Arr.Add a, a
Next
For i = 1 To Arr.count
Cells(1, i+2) = Arr(i) ' output collection in some cells
Next
'''''''''''''''''''''''''
concatenation part
'''''''''''
Thank you.
you could use a late binding "on the fly" Dictionary object:
Sub main()
Dim cell As Range
With CreateObject("Scripting.Dictionary")
For Each cell In Range("A1:A4") '<--| change "A1:A4" to whatever range you need
.Item(cell.Value) = .Item(cell.Value) + 1
Next cell
Range("B1").Value = Join(.keys, ",")
End With
End Sub
in the array, split again, spit(a,"=") adding index 1 to another array, not a collection, then use JOIN to put it back together
x=0
redim arrOutput(ubound(ary))
For Each a In ary
arrOutput(x)= split(a,"=")(1)
x=x+1
Next
range("b1")=join(arrOutput,",")
or just split by = and take odd numbers from the resulting array maybe?
If you need to hold something unique - always think about dictionary, cause of Exists method. Here's a small example:
Sub test()
Dim NonUniqueValues As Variant
Dim UniqueValues As Object
Dim i As Long
'gather source array
NonUniqueValues = Union([A1], [A2], [A3], [A4]).Value2
'set dict
Set UniqueValues = CreateObject("Scripting.Dictionary")
'loop over array
For i = LBound(NonUniqueValues, 1) To UBound(NonUniqueValues, 1)
If Not UniqueValues.Exists(NonUniqueValues(i, 1)) Then _
Call UniqueValues.Add(Key:=NonUniqueValues(i, 1), Item:=NonUniqueValues(i, 1))
Next
'output
[B1] = Join(UniqueValues.Keys, ",")
End Sub
Perhaps:
Public Function KonKat(rng As Range) As String
Dim c As Collection, r As Range, i As Long
Set c = New Collection
On Error Resume Next
For Each r In rng
c.Add r.Value, CStr(r.Value)
Next r
On Error GoTo 0
For i = 1 To c.Count
KonKat = KonKat & "," & c.Item(i)
Next i
KonKat = Mid(KonKat, 2)
End Function
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.
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.