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
Related
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 am trying to read an Excel range to a variable of type string.
Currently I have achieved it with a work around. I copied the range to clipboard and used a ReadClipBoard function that reads the clipboard as assigns to variable. This method is not efficient and also some times it gives error due to clipboard issues with VBA.
Workaround Code:
Dim variable as string
Range("A1:C5").Copy
variable = ReadClipBoard()'Function that returns clipboard text
Is there a better way to do it?
This will turn each line into a tab-separated string and the whole range into a line-separated string.
Public Function RangeToText(ByRef r As Range)
Dim vaData As Variant
Dim aOutput() As String
Dim i As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
'Put range into a two dim array
vaData = r.Value
'Make one dim array the same number of rows
ReDim aOutput(1 To UBound(vaData, 1))
'Make strings With tabs out of each row
'and put into one dim array
For i = LBound(vaData, 1) To UBound(vaData, 1)
aOutput(i) = Join(wf.Index(vaData, i), vbTab)
Next i
'join all the strings into one multi-line string
RangeToText = Join(aOutput, vbNewLine)
End Function
In the Immediate Window
?rangetotext(sheet1.Range("A1:C5"))
Here Here Here
is is is
some some some
column 1 column 2 column 3
text text text
The Index worksheet function is used to process only one row at a time because Join requires a one dimensional array
If you are reading more than once cell, then the variable would be an array For example:
Sub ArrayDemo()
Dim r As Range
Set r = Range("A1:C5")
variable = r
End Sub
is nearly equivalent to :
Sub ArrayDemo2()
Dim r As Range
Set r = Range("A1:C5")
Dim variable(1 To 5, 1 To 3) As Variant
For i = 1 To 5
For j = 1 To 3
variable(i, j) = Cells(i, j).Value
Next j
Next i
End Sub
Naive way is to concatenate all the content into a string, is that ok for you?
Function ConcatCells(r as range, optional sep as string) as string
dim c as range
dim s as string
s=""
if sep is missing then sep=" "
for each c in r.cells
s = s & c & sep
next c
s=left(s, len(s) - len(sep))
ConcatCells=s
end sub
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 have a need to convert the following function to accept a user selected 2 dimensional range [datatype] in place of Arr [ the arbitrary custom defined Array] that is used in it's place. I want to do this so I can run worksheet functions on the data. I know it can be done when the range object is selected, but my data at one points need to be converted to a variant, then re assigned to a [new] range on the new worksheet (aka 'put the array values on the worksheet), then reread back as a range when it does (aka ' load the worksheet values back into the array)
Sub SortViaWorksheet()
Dim Arr(1 To 5) As String ' this is the array to be sorted
Dim WS As Worksheet ' temporary worksheet
Dim R As Range
Dim N As Long
' fill up the array with some
' aribtrary values.
Arr(1) = "aaa"
Arr(2) = "zzz"
Arr(3) = "mmm"
Arr(4) = "ttt"
Arr(5) = "bbb"
Application.ScreenUpdating = False
' create a new sheet
Set WS = ThisWorkbook.Worksheets.Add
' put the array values on the worksheet
Set R = WS.Range("A1").Resize(UBound(Arr) - LBound(Arr) + 1, 1)
R = Application.Transpose(Arr)
' sort the range
R.Sort key1:=R, order1:=xlAscending, MatchCase:=False
' load the worksheet values back into the array
For N = 1 To R.Rows.Count
Arr(N) = R(N, 1)
Next N
' delete the temporary sheet
Application.DisplayAlerts = False
WS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
' test/debug/confirmation
For N = LBound(Arr) To UBound(Arr)
Debug.Print Arr(N)
Next N
End Sub
In other words, I want to be able to pass in a user selected 2d range that will be converted to a variant, then export this variant to a 2d range in a worksheet that is reloaded back into a range for vba to work with and run functions on. I understand this example uses .sort, which requires a 1d array. I do not intend on using sort, but rather things like worksheet functions on this new range, such as rank, countif, average, max, min, median, etc
My friend pointed out that the example above uses a 1d range as input and exports a 1d array to the worksheet. So I would need the ability to select a 2d range as input and export a 2d range to a worksheet that is subsequently reread as a new range.
You can convert a worksheet range to an array and back again using the range's Value property. For example to read the current workbook selection into an array, process it, and write it back:
Sub Example()
Dim myArr() As Variant
myArr = Selection.Value
For i = LBound(myArr, 1) To UBound(myArr, 1)
For j = LBound(myArr, 2) To UBound(myArr, 2)
myArr(i, j) = myArr(i, j) + 5
Debug.Print CStr(i) & "_" & CStr(j) & ": " & myArr(i, j)
Next j
Next i
Selection = myArr
End Sub
To pass the range into a function for processing:
Sub TestMain()
Selection = TestProcess(Selection)
End Sub
Function TestProcess(userRange As Range) As Variant
Dim result() As Variant
result = userRange.Value
For i = LBound(result, 1) To UBound(result, 1)
For j = LBound(result, 2) To UBound(result, 2)
result(i, j) = result(i, j) + 5
Debug.Print CStr(i) & "_" & CStr(j) & ": " & result(i, j)
Next j
Next i
TestProcess = result
End Function
Is this what you want to do for example:
Public Sub ProcessRange(ByRef r As Range)
Dim vals() As Variant
vals = r.Value
Dim rows As Integer, cols As Integer
rows = r.rows.Count: cols = r.Columns.Count
Dim x As Double
x = WorksheetFunction.Average(vals)
' 3.66666
End Sub
when called by ProcessRange Range("B4").Resize(3, 3) in
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)