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
Related
I am trying to write a VBA function that takes a table with two columns as input. I want to return the elements in column 2 for which the corresponding row in column 1 is 3. Basically the equivalent of a where clause in SQL.
The logic of the code seems fine, however I get a type mismatch error. I declare the function As Variant and the array I want to return is As Variant as well.
Function FilterTable(tableName As String) As Variant
Dim table As range
Dim cell As range
Dim names As range
Dim i As Integer
Dim names_2(100) As Variant
Dim j As Integer
Dim test As String
i = 1
j = 1
Set table = ActiveSheet.range(tableName).Columns(1)
Set names = ActiveSheet.range(tableName).Columns(2)
For Each cell In table.Cells
If cell = 3 Then
names_2(i) = names.Cells(j, 1).Value
i = i + 1
End If
j = j + 1
Next
FilterTable = names_2
End Function
Why do I get a Type Mismatch error, and how can I fix it?
There are a few problems with your code but nothing that should cause a type mismatch unless you have worksheet errors (e.g. #N/A, #DIV/0!, etc) in your data.
You should be aware of what worksheet your table is on; don't rely on activesheet.
A 1-D array defaults as zero-based, not one-based.
You should remove the excess (empty) elements in your array after populating it. Use the Locals window or set a Watch on your array to see it populate and resize as you step through the function with F8.
Option Explicit
Sub main()
Dim n As Variant, i As Long
n = FilterTable("table1")
For i = LBound(n) To UBound(n)
Debug.Print n(i)
Next i
End Sub
Function FilterTable(tableName As String) As Variant
Dim table As Range, names As Range, cell As Range
Dim i As Long, j As Long
Dim names_2 As Variant
i = 0
j = 1
ReDim names_2(100)
Set table = Worksheets("Sheet3").Range(tableName).Columns(1)
Set names = Worksheets("Sheet3").Range(tableName).Columns(2)
For Each cell In table.Cells
If Not IsError(cell) Then
If cell = 3 Then
names_2(i) = names.Cells(j, 1).Value
i = i + 1
End If
End If
j = j + 1
Next cell
ReDim Preserve names_2(i - 1)
FilterTable = names_2
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
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
So I am trying to create a function that will get all the unique values in a range, I'm new vba so I've made an attempt but it doesn't work (#VALUE). I eventually want each value in the array to be output one cell below it.
Here is the Code I wrote
Option Explicit
Function getUnique(dataSet As Range, Column As String)
Dim data() As String
Dim dataSize As Integer
Dim dictionary As Object
Dim i As Long
dataSize = dataSet.Rows.Count
Set dictionary = CreateObject("Scripting.Dictionary")
ReDim data(dataSize)
For i = 1 To UBound(data)
data(i) = dataSet(Column & i).Value
dictionary(data(i)) = 1
Next i
Dim v As Variant
For Each v In dictionary.Keys()
Debug.Print dictionary.Keys
Next v
Your code can work with a few changes, as indicated here:
Function getUnique(dataSet As Range) '<<< remove Column
Dim data() As String
Dim dataSize As Integer
Dim dictionary As Object
Dim i As Long
dataSize = dataSet.Rows.Count
Set dictionary = CreateObject("Scripting.Dictionary")
ReDim data(dataSize)
For i = 1 To UBound(data)
data(i) = dataSet.Cells(i, 1).Value '<<< using Cells
dictionary(data(i)) = 1
Next i
Dim v As Variant
For Each v In dictionary.Keys()
Debug.Print v '<<<
Next v
End Function
If, though, you are attempting to use this Function in a Worksheet cell then it won't work if you attempt to put values into other cells. User-Defined Functions don't work like that and you'll have to make it a Sub and run it on clicking a button, or some other event.
Dim myText As String
myText= Range("a3").Text
Returns the formatted value in cell A3, but
myText= Range("a3:c7").Text
gives me an error.
How do I get strings representing formatted values from a multi-cell range, while preserving the number format? i.e. the format of the output text would be the same as if copy-pasting from the range to a text editor.
The only way to get multiple cell values into an array with one single statement (no loops) is with a Variant array.
Dim varItemName As Variant
varItemName = Range("a3:c7")
If you really absolutely need the names to be type String, then just CStr them later when you use them.
output = FunctionRequiringStringArgument(CStr(varItemName(1,2))
EDIT: Okay, okay, you want strings with same format as in sheet.
Here's a full working example.
Dim strMyFormat1 As String
Dim varItemName As Variant
Dim strItemName() As String
Dim strItemNameBF() As String
Dim iCol As Long
Dim iRow As Long
Dim rngMyRange As Range
Set rngMyRange = Range("A3:C7")
varItemName = rngMyRange
ReDim strItemName(LBound(varItemName, 1) To UBound(varItemName, 1), _
LBound(varItemName, 2) To UBound(varItemName, 2))
'// Take a sample of the format
strMyFormat1 = Range("A3").NumberFormat
'// Apply format sample to all values
For iRow = LBound(varItemName, 1) To UBound(varItemName, 1)
For iCol = LBound(varItemName, 2) To UBound(varItemName, 2)
strItemName(iRow, iCol) = Format(varItemName(iRow, iCol), strMyFormat1)
Next iCol
Next iRow
'// Can also apply to only some values -- adjust loops.
'// More loops go here if many format samples.
'// If all cells have different formats, must use brute force -- slower.
ReDim strItemNameBF(1 To rngMyRange.Rows.Count, _
1 To rngMyRange.Columns.Count)
For iRow = 1 To rngMyRange.Rows.Count
For iCol = 1 To rngMyRange.Columns.Count
strItemNameBF(iRow, iCol) = rngMyRange.Cells(iRow, iCol).Text
Next iCol
Next iRow
For Each c In Range("a3:c7")
ItemName = c.Text
Next c
This will give you each cell one after the other.
This is a modified version of one of the post here and it worked for me.
Function Range2Text(ByVal my_range As Range) As String
Dim i As Integer, j As Integer
Dim v1 As Variant
Dim Txt As String
v1 = my_range
For i = 1 To UBound(v1)
For j = 1 To UBound(v1, 2)
Txt = Txt & v1(i, j)
Next j
Txt = Txt & vbCrLf
Next i
Range2Text = Txt
End Function
Make a collection and run through all the Areas of the range and collect the text into
the collection.
dim i as integer, j as integer
Dim v1 as variant
v1=range("a3:c7")
for i=1 to ubound(v1)
for j=1 to ubound(v1,2)
debug.print v1(i,j)
next j
next i