Making Selected Range into an Array and doing stuff with it - vba

I'm trying to teach myself VBA writing some little things. I'm trying to make something that allows you to select some data and then calculates the mean and variance. My code is as follows :
Sub VarianceCalculator()
Dim k As Integer
Dim SelectedData As Range
Dim SelectedDataArray() As Variant
Dim Var As Double
Dim Mu As Double
On Error Resume Next
Set SelectedData = Application.InputBox("Select a range of data to be
calculated", Default:=Selection.Address, Type:=8)
On Error GoTo 0
SelectedDataArray = Range(SelectedData.Address)
k = UBound(SelectedDataArray)
Call VarianceCalculatorWithArray(SelectedDataArray, k)
MsgBox ("The selected data has variance " & Var & " and has mean " & Mu)
End Sub
Sub VarianceCalculatorWithArray(Data() As Variant, k As Integer)
Dim Var As Double
Dim Mu As Double
Dim j As Integer
Dim i As Integer
ReDim Data(k) As Variant
Mu = 0
Var = 0
For j = 0 To k
Mu = Mu + (Data(j)) / (k + 1)
Next j
For i = 0 To k
Var = Var + ((Data(i) - Mu) ^ (2)) / (k + 1)
Next i
End Sub
I think the error is that somehow the data is not getting transferred into the array but I can't find a solution to this.
Thanks!!

There are two major problems:
(1) If you want to pass the variables Var and Mu from one procedure to another you'll have to declare them as public variables before the first procedure. The alternative is to setup VarianceCalculatorWithArray as a function.
(2) The array Data() is 2D as a range consists of rows and columns. So, if you want to use an element from this array, you'll have to address it as Data(1, 1). Also note, that this range array starts with row 1 and column 1. Therefore your for...next statements should start with 1 and not with 0.
Note, that you can always set a breakpoint in order to check if data is transferred into the array.

Related

VBA List all possible combination of variable number of items (number of nested loops as variable)

gentleman! I am having trouble with figuring out a way to define the number of elements as variable when listing all possible combinations. I have a hard coded example of this where number of elements = 3
'Declare variables
Dim a as long
Dim b as Long
Dim C as Long
Dim ElementsArray as variant
'Array
ElementsArray = array("1400","1900","2400")
'Loop through combinations
for a = lbound(ElementsArray) to ubound(ElementsArray)
for B= lbound(ElementsArray) to ubound(ElementsArray)
for c = lbound(ElementsArray) to ubound(ElementsArray)
debug.print(ElementsArray(a) & " - " & ElementsArray(b) & " - " & ElementsArray(c))
next c
next b
next a
But What I am looking for is a code in which perhaps the number of nested For loops is a variable or some other ways to permutate through all possible combinations. Please help solve this problem.
Here is an example of a recursive implementation. Just be warned that you shouldn't make your array too large as you will get n to the power of n solutions - for 4 elements, that's 256, for 5 elements 3'125, for 6 you get 46'656 and for 7 already 823'543 - don't complain if the program takes a long time to execute. And of course you need a way to do something with every permutation.
Option Explicit
Sub test()
Dim ElementsArray As Variant
ElementsArray = Array("1400", "1900", "2400")
ReDim SolutionArray(LBound(ElementsArray) To UBound(ElementsArray))
recursion ElementsArray, SolutionArray, LBound(ElementsArray)
End Sub
Sub recursion(elements, solution, level As Long)
Dim i As Long
For i = LBound(elements) To UBound(elements)
solution(level) = elements(i)
If level = UBound(elements) Then
Debug.Print Join(solution, " - ")
Else
recursion elements, solution, level + 1
End If
Next i
End Sub
Update: This is the result:
Update
Still not sure if I understand. The following code will create a list of n-Tupel out of an array of values.
In the example (test), we have an array of 4 values and set n to 3 (defined as constant).
Sub test()
Const n = 3
Dim ElementsArray As Variant
ElementsArray = Array("1400", "1900", "2400", "9999")
ReDim SolutionArray(0 To n - 1)
recursion ElementsArray, SolutionArray, LBound(ElementsArray)
End Sub
Sub recursion(elements, solution, level As Long)
Dim i As Long
For i = LBound(elements) To UBound(elements)
solution(level) = elements(i)
If level = UBound(solution) Then
Debug.Print Join(solution, " - ")
Else
recursion elements, solution, level + 1
End If
Next i
End Sub

Saving large quantity of String in vba excel

I have to make a application to load images in excel vba, encrypt that image and save it in cells. My problem is the limit of characters in cell ( 32.767 characters ) and my encrypted string is like 800k characters.
I make a function to make a array of string with custom string character length to save in a row but when i save in cells i recive this error:
Public Function SplitString(ByVal TheString As String, ByVal StringLen As Integer) As String()
Dim ArrCount As Integer 'as it is declared locally, it will automatically reset to 0 when this is called again
Dim I As Long 'we are going to use it.. so declare it (with local scope to avoid breaking other code)
Dim TempArray() As String
ReDim TempArray((Len(TheString) - 1) \ StringLen)
For I = 1 To Len(TheString) Step StringLen
TempArray(ArrCount) = Mid$(TheString, I, StringLen)
ArrCount = ArrCount + 1
Next
SplitString = TempArray 'actually return the value
End Function
Dim StringArray As Variant
StringArray = SplitString(EncodeFile(.SelectedItems(1)), 30000)
Dim ind As Integer
ind = 2
For index = 1 To UBound(StringArray)
Sheet5.Cells(55, ind).value = StringArray(index)
ind = ind + 1
Next index
I solve this problem by adding a delay in for loop but it's not a optimal solution
For index = 1 To UBound(StringArray)
Sheet5.Cells(55, ind).value = StringArray(index)
ind = ind + 1
Application.Wait (Now + TimeValue("00:00:01"))
Next index
And now the question: Can I make this more faster or a better way to solve this problem ?
Dump the array into the cells within one row without the loop.
Sheet5.Cells(55, "A").resize(1, ubound(StringArray) + 1) = StringArray

Excel VBA - Formula Counting Unique Value error

I am trying to calculate the count of Unique values based on a condition.
For example,
For a value in column B, I am trying to count the Unique values in Column C through VBA.
I know how to do it using Excel formula -
=SUMPRODUCT((B2:B12<>"")*(A2:A12=32)/COUNTIF(B2:B12,B2:B12))
that value for 32 is dynamic - Programmatically I am calling them inside my vba code as Name
This is my code :
Application.WorksheetFunction.SumProduct((rng <> "") * (rng2 = Name) / CountIfs(rng, rng))
This is the sample data with the requirement
Alternatively, I Concatenated both the columns for keeping it simple and hoping to identify the Unique values which starts with name* method.
I don't know where I am going wrong. Kindly share your thoughts.
You may try something like this...
Function GetUniqueCount(Rng1 As Range, Lookup As String) As Long
Dim x, dict
Dim i As Long, cnt As Long
Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
For i = 1 To UBound(x, 1)
If x(i, 1) = Lookup Then
dict.Item(x(i, 1) & x(i, 2)) = ""
End If
Next i
GetUniqueCount = dict.Count
End Function
Then you can use it like below...
=GetUniqueCount($A$2:$B$10,C2)
Where A2:B10 is the data range and C2 is the name criteria.
I'd put the values into an array, create a temporary 2nd array and only add values to this array if they are not already present, and then replace the original array. Then it's just a simple matter to sum the unique values:
Sub Unique
dim arr(10) as variant, x as variant
dim arr2() as variant
for x = 1 to 10 ' or whatever
arr(x) = cells(x, 1) ' or whatever
next x
arr2 = UniqueValuesArray(arr)
' now write some code to count the unique values, you get the idea
End Sub
Function UniqueValuesArray(arr As Variant) As Variant()
Dim currentRow, arrpos As Long
Dim uniqueArray() As Variant
Dim x As Long
arrpos = 0
ReDim uniqueArray(arrpos)
For x = 0 To UBound(arr)
If UBound(Filter(uniqueArray, arr(x))) = -1 Then
ReDim Preserve uniqueArray(arrpos)
uniqueArray(arrpos) = arr(x)
arrpos = arrpos + 1
End If
Next x
UniqueValuesArray = uniqueArray
End Function

receiving "out of range" error, can't figure out why

Let me start by first thanking everyone for the help/intention to help. This community is phenomenal. Second: I'm pretty new at this- before this week I'd learned basic in highschool a decade ago but no other programming experience outside of theory.
Without further ado, here's my issue:
Working on code to find unique variables (I know there's a lot of opensource stuff out there, need to customize this though). When I go to populate the array with the very first string I run into an 'out of range' error at array(1), which I had explicity set (1 TO UB), with UB being the upper bound. I've also double checked the value of UB with msgbox and it's at 15 with my dummy data, so that shouldn't be an issue. I've set the values in the array to empty (have also done so with 0, to no avail).
The error occurs at "ResultArray(1) = CurrentArray(1)"
I'm at a loss; any assistance would be much appreciated.
Option Explicit
Sub unque_values()
'''''''''Variable declaration
'
' CurrentArray() is the array taken from the worksheet
' Comp is the method of comparing inputs (either case sensitive or case insensitive)
' resultarray() is the array that unique values are placed
' UB is the upper bound of Result Array
' resultindex is the variable that keeps track of which cells are unique and which are not
' n is a helped variable that assists with resizing the array
Dim currentarray() As Variant
Dim comp As VbCompareMethod
Dim resultarray() As Variant
Dim UB As Long
Dim resultindex As Long
Dim n As Long
Dim v As Variant
Dim inresults As Boolean
Dim m As Long
' set variables to default values
Let comp = vbTextCompare
Let n = 0
' count the number of cells included in currentarray and populate with values
Let n = ActiveWorkbook.Worksheets("Data").Range("A:A").Count
Let UB = ActiveWorkbook.Worksheets("Data").Range("A" & n).End(xlUp).Row
' dimension arrays
ReDim resultarray(1 To UB)
ReDim currentarray(1 To UB)
' don't forget to change to named ranges
Let currentarray() = Range("f2", "f" & UB)
' populate resultarray with empty values
For n = LBound(resultarray) To UBound(resultarray)
resultarray(n) = Empty
Next n
MsgBox (n)
'check for invalid values in array
For Each v In currentarray
If IsNull(n) = True Then
resultarray = CVErr(xlErrNull)
Exit Sub
End If
Next v
' assumes the first value is unique
resultindex = 1
'''''''''''''''''''''''''''''''''''''''''error is this line''''''''''''''
resultarray(1) = currentarray(1)
' Search for duplicates by cycling through loops
' n = index of value being checked
' m = index of value being checked against
For n = 2 To UB
Let inresults = False
For m = 1 To n
If StrComp(CStr(resultarray(m)), CStr(currentarray(n)), comp) = 0 Then
inresults = True
Exit For
End If
Next m
If inresults = False Then
resultindex = resultindex + 1
resultarray(resultindex) = currentarray(n)
End If
Next n
ReDim Preserve resultarray(1 To resultindex)
End Sub
You've assigned to currentArray a range array. These are always two-dimensional arrays.
You should be able to resolve it with:
resultarray(1) = currentarray(1, 1)
You would need to modify a few more lines in your code to refer to both dimensions of the array.
Alternatively, with the least manipulation to your existing code, transpose the array which turns it to a one-dimensional array. This should require no other changes to your code.
Let currentArray() = Application.Transpose(Range("f2", "f" & UB))
Try with ActiveWorkbook.Worksheets("Data").UsedRange.Columns(1).cells.Count

Excel VBA - Perform Operations on visible cells only

I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.