I have identified unique values in a list of data by the method I have abbreviated below:
Dim dictionary as scripting.dictionary
Dim data() as String
Dim dataSize as Integer
Dim j as integer
Dim v as variant
DataSize = myRange.Rows.Count
Redim data(dataSize)
For j = 1 to UBound(data)
data(j) = myRange.Cells(j,1).Value
dictionary(data(j)) = 1
Next j
This should be storing the unique values from myRange as the Key values. However, I can't seem to figure out how to access the values. I have tried the following:
For each v in dictionary.Keys()
myVar = v
'dostuff to myVar
next v
and
For each v in dictionary.Keys()
myVar = dictionary.Keys(v)
'dostuff to myVar
next v
but neither works. What am I missing?
Add Set dictionary = New dictionary and then you can loop through:
Sub t()
Dim dictionary As Scripting.dictionary
Dim data() As String
Dim dataSize As Integer
Dim j As Integer
Dim v As Variant
dataSize = myRange.Rows.Count
Set dictionary = New dictionary
ReDim data(dataSize)
For j = 1 To UBound(data)
data(j) = myRange.Cells(j, 1).Value
dictionary(data(j)) = 1
Next j
Dim i As Long
For i = 0 To dictionary.Count - 1
Debug.Print dictionary.Keys()(i) & " " & dictionary.Items()(i)
Next i
End Sub
Related
I am trying to store the values inside an array. I am facing a problem it says subscript out of range.
This is the code,
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim j As Long
Dim i as Long
set wk = Activeworkbook
lastrow_header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
j = 1
For i = 2 To lastrow_header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
HeaderArray(j - 1) = HeaderValue // Subscript out of range error
j = j + 1
End If
Next
End Sub
What is the mistake I am making. Kindly advise.
You need to declare the size of the array before trying to put data in it. Use COUNTA to find the number of cells with data in your range:
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim lastrow_Header_Config As Long
Dim j As Long
Dim i As Long
Set Wk = ActiveWorkbook
lastrow_Header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
ReDim HeaderArray(Application.WorksheetFunction.CountA(Wk.Sheets("Config").Range("W2:W" & lastrow_Header_Config))-1) As Variant
j = 0
For i = 2 To lastrow_Header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
HeaderArray(j) = HeaderValue
j = j + 1
End If
Next
End Sub
try this and see how it works for you
pay close attention to the ReDim HeaderArray(j) line and the ReDim Preserve HeaderArray(j) lines
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim j As Long
Dim i As Long
Set Wk = ActiveWorkbook
lastrow_header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
j = 1
ReDim HeaderArray(j) '<============= initialize your array length
For i = 2 To lastrow_header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
ReDim Preserve HeaderArray(j) '<================= adjust your array length to accomodate the additional info
HeaderArray(j - 1) = HeaderValue '// Subscript out of range error
j = j + 1
End If
Next
End Sub
Also you might want to read up on using the option keyword. Arrays by default have the first data point at index 0 so for example array(1) creates an array that has 1 data point, however to reference that data point you would use array(0). if you wanted the first data point in the array to be referenced using array(1), then you would use the Option Base 1 keyword at the very top of your module.
On the first pass, j = 1. Therefore you try to set HeaderArray(0) a value, while HeaderArray is probably 1 based.
You can eventually use Option Base 0, or explicitely Redim HeaderArray(0 to 10) (or whatever value you need)
I have 3 informations on a row and I can have multiple row selected. So what I'm looking for is a way to split a first time each row into an array.
That's what I'm doing here.
line = Split(msg, ",")
Then I want to for every line to split info to obtain a matrix with first identifer the line and the second is the info
ReDim pro(Ubound(line),3)
For i = 0 To Ubound(line)
pro(i) = Split(ligne(i), "/")
Next
But It throw me a mismatch error so I don't know how to do it
for example :
I have this
msg1/1250/Description,msg2/1500/Description2,msg3,45656,Desctiption3
And finally have this :
pro(0,0) = msg1
pro(0,1) = 1250
pro (1,1) = 1500
etc ...
Thank you
Not optimal in any way, but it should give you a start:
Dim RowCount As Integer
Dim i As Integer
Dim j As Integer
Dim x As Variant
Dim y As Variant
Line = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
RowCount = UBound(Split(Line, ",")) + 1
ReDim pro(RowCount, 3)
For Each x In Split(Line, ",")
j = 0
For Each y In Split(x, "/")
pro(i, j) = y
j = j + 1
Next y
i = i + 1
Next x
What you have initially as pro is called a "jagged array". You can use a "double-transpose" to transform it into a 2D array. But beware that it needs that all the "line arrays" be of the same size:
Function toMatrix(msg as string)
Dim line: line = Split(msg, ",")
ReDim pro(UBound(line))
Dim i As Long
For i = 0 To UBound(line)
pro(i) = Split(line(i), "/")
Next
' transform array of arrays into a 2D array.
toMatrix = Application.Transpose(Application.Transpose(pro))
End Function
Sub Test
Dim msg As String
msg = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
Dim ar
ar = toMatrix(msg) ' ar is now a 2D array
End Sub
This is how I did it:
Option Explicit
Public Sub TestMe()
Dim strInput As String
Dim arrVals As Variant
Dim arrVar As Variant
Dim arrVar2 As Variant
Dim arrResult As Variant
Dim lngCount As Long: lngCount = 0
strInput = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
arrVals = Split(strInput, ",")
ReDim arrResult(UBound(arrVals), 1)
For Each arrVar In arrVals
arrVar2 = Split(arrVar, "/")
arrResult(lngCount, 0) = arrVar2(0)
arrResult(lngCount, 1) = arrVar2(1)
lngCount = lngCount + 1
Next arrVar
End Sub
That's the result:
As far as I did not see that you need a DescriptionN I have skipped it.
I have the following code to retrieve a selection then making it a array of string.
Dim strArgument As Variant
Dim irange As Range
Dim ricosString As Variant
Set irange = Selection
ricosString = RangeToStringArray(irange)
Dim vArray As Variant
For i = LBound(ricosString) To UBound(ricosString)
Set vArray = ricosString(i)
My problem here is on the ricosString(i). It is throwing an error Subscript out of range. Any ideas why?
Here is the code for RangeToStringArray
Public Function RangeToStringArray(theRange As Excel.Range) As String()
Dim variantValues As Variant
variantValues = theRange.Value
Dim stringValues() As String
ReDim stringValues(1 To UBound(variantValues, 1), 1 To UBound(variantValues, 2))
Dim columnCounter As Long, rowCounter As Long
For rowCounter = UBound(variantValues, 1) To 1 Step -1
For columnCounter = UBound(variantValues, 2) To 1 Step -1
stringValues(rowCounter, columnCounter) = CStr(variantValues(rowCounter, columnCounter))
Next columnCounter
Next rowCounter
RangeToStringArray = stringValues
End Function
RangeToStringArray is 2 dimensional but you reference it as 1 dimensional
Set vArray = ricosString(i)
Also Ricostring is not an object so you should not use Set
Regarding that RangeToStringArray function, I don't really see its interest: why don't you just use ricosString = irange, which would be simpler and faster?
Define your ricosString as a proper String Array:
Dim ricosString() As String
Replace your RangeToStringArray Function with a proper one:
Public Function RangeToStringArray(theRange As Excel.Range) As String()
Dim cell As Range
Dim values() As String
Dim i As Integer
i = 0
ReDim values(theRange.Cells.Count)
For Each cell In theRange
values(i) = cell.Value
i = i + 1
Next cell
RangeToStringArray = values
End Function
Then you can refer to the values in the array like this:
vArray = ricosString(i) 'without Set
I've got the following Macro and Function working, but the pasted result has a layer of zeroes in the left side and top of the result. hope you guys can figure out the error in my code. I am to believe the error is in the function:
Sub AutoCovariance()
Dim DataRange As Range
Dim VarCovarOutPutRange As Range
Dim NumberOfReturns As Long
Dim NumberOfStocks As Long
Dim ArrayColumnsCounter As Double
Dim ArrayRowsCounter As Double
Dim ReturnsArray() As Double
Dim DataReturns() As Variant
Dim DataRowCounter As Long
Dim DataColumnCounter As Long
Dim Stock As Long
Dim dAutoCoVar() As Double
Set DataRange = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").DataBodyRange
NumberOfReturns = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").DataBodyRange.Rows.Count
NumberOfStocks = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").Range.Columns.Count
ArrayColumnsCounter = 0
ArrayRowsCounter = 0
ReDim Preserve ReturnsArray(10, 1)
' Creating returns array
For DataColumnCounter = 1 To NumberOfStocks
ArrayRowsCounter = ArrayRowsCounter + 1
For DataRowCounter = 1 To NumberOfReturns
ArrayColumnsCounter = ArrayColumnsCounter + 1
ReDim Preserve ReturnsArray(NumberOfStocks, ArrayColumnsCounter)
For Stock = 1 To NumberOfStocks
ReturnsArray(Stock, ArrayColumnsCounter) = DataRange(DataRowCounter, Stock).Value
Next Stock
Next DataRowCounter
ArrayColumnsCounter = ArrayColumnsCounter - 100
Next DataColumnCounter
' Transfer ReturnsArray Data to DataReturns
ReDim DataReturns(NumberOfReturns, NumberOfStocks)
DataReturns = Application.WorksheetFunction.Transpose(ReturnsArray)
' calculate the autocovariance matrix
dAutoCoVar = Autocovar(DataReturns)
' write to the worksheet, for debug
Set VarCovarOutPutRange = ThisWorkbook.Worksheets(Sheet1.Name).Range(Cells(1, NumberOfStocks + 2), Cells(NumberOfStocks, NumberOfStocks * 2 + 2))
VarCovarOutPutRange.Value = dAutoCoVar
End Sub
And the Function
Function Autocovar(DataReturns() As Variant) As Double()
Dim dArrResult() As Double
Dim j As Long, k As Long
' redim the result array as a square array.
ReDim dArrResult(1 To UBound(DataReturns, 2), 1 To UBound(DataReturns, 2))
' calculate the autocovariance matrix
For j = 1 To UBound(DataReturns, 2)
For k = 1 To UBound(DataReturns, 2)
With Application.WorksheetFunction
dArrResult(j, k) = .Covariance_S(.Index(DataReturns, 0, j), .Index(DataReturns, 0, k))
End With
Next k
Next j
Autocovar = dArrResult
End Function
The problem sounds typical for wrong array indices.
Your array operations all assume that the first index is 1. But by default, if you ReDim an array like this:
ReDim DataReturns(NumberOfReturns, NumberOfStocks)
the indices will start at 0.
Try adding this line at the beginning of your module:
Option Base 1
This sets the first index of all arrays not explicitely declared as Dim ar(x to y) to a base index of 1.
I have a simple piece of code written which basically scans through column A, detects for a condition and once the condition is met in a row, it copies the cell in column B of the same row into an array. I was hoping someone could help me make a nested array which would not only store the value in column B but also its rowcount. here is what i have so far, any help is appreciated.
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim ii As Integer
ii = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
Dim oldarray() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim oldvalue As Range
ReDim Preserve oldarray(ii)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
oldarray(ii) = oldvalue.Value
ii = ii + 1
End If
End If
Next
You need a two dimensional array. Use one dimension for the value and the other for the row. Here's an example
Sub GetArray()
Dim vaInput As Variant
Dim rRng As Range
Dim aOutput() As Variant
Dim i As Long
Dim lCnt As Long
'Define the range to test
Set rRng = DataSheet.Range("A1", DataSheet.Cells(DataSheet.Rows.Count, 1).End(xlUp)).Resize(, 2)
'Put the values in that range into an array
vaInput = rRng.Value
'Lopo through the array
For i = LBound(vaInput, 1) To UBound(vaInput, 1)
'Skip blank cells
If Len(vaInput(i, 1)) > 0 Then
'Test for the sheet's name in the value
If Split(vaInput(i, 1), "$")(0) = DHRSheet.Name Then
'Write the value and row to the output array
lCnt = lCnt + 1
'You can only adjust the second dimension with a redim preserve
ReDim Preserve aOutput(1 To 2, 1 To lCnt)
aOutput(1, lCnt) = vaInput(i, 2) 'write the value
aOutput(2, lCnt) = i 'write the row count
End If
End If
Next i
'Output to see if you got it right
For i = LBound(aOutput, 2) To UBound(aOutput, 2)
Debug.Print aOutput(1, i), aOutput(2, i)
Next i
End Sub
Dim col2 As Range
Dim cell2 As Excel.Range
Dim rowcount2 As Integer
Dim arr() As Variant
Dim p As Integer
p = 0
rowcount2 = DataSheet.UsedRange.Rows.Count
Set col2 = DataSheet.Range("A1:A" & rowcount2)
Dim parsedcell() As String
For Each cell2 In col2
If cell2.Value <> Empty Then
parsedcell = Split(cell2.Value, "$")
sheetName = parsedcell(0)
If sheetName = DHRSheet.Name Then
Dim subarr(1) As Variant
Dim oldvalue As Range
ReDim Preserve arr(p)
Set oldvalue = DataSheet.Cells(cell2.Row, 2)
subarr(0) = oldvalue.Value
subarr(1) = cell2.Row
arr(p) = subarr
p = p + 1
'MsgBox (oldvalue)
End If
End If
Next