Correlation of Two Arrays in VBA - arrays

everyone. I'm new to VBA, and recently ran into this issue that when I run the following function on two ranges, the excel gave a warning - "Run-Time error '1004': Method 'Correl' of object 'WorksheetFunction' failed."
I'm wondering what's wrong in my case and how I can go around this warning. Thanks a lot.
'Calculate correlation coefficient with whatever sizes of two data sets
Function CorrelationDifferentSizes(data1, data2) As Double
Dim length1 As Integer
Dim length2 As Integer
'length1 = UBound(data1) - LBound(data1) + 1
'length2 = UBound(data2) - LBound(data2) + 1
length1 = data1.Rows.Count
length2 = data2.Rows.Count
Dim tmp1() As Variant
Dim tmp2() As Variant
ReDim tmp1(1 To length2)
ReDim tmp2(1 To length1)
If length1 > length2 Then
Dim i As Integer
Dim j As Integer
For i = 1 To length2
tmp2(i) = data2.Cells(i, 1)
Next i
For j = 1 To (length1 - length2)
tmp2(length2 + j) = 0
Next j
ElseIf length2 > length1 Then
Dim m As Integer
Dim n As Integer
For m = 1 To length1
tmp1(m) = data1.Cells(m, 1)
Next m
For n = 1 To (length2 - length1)
tmp1(length1 + n) = 0
Next n
End If
'Dim a1
'Dim a2
'a1 = Array(tmp1)
'a2 = Array(tmp2)
CorrelationDifferentSizes = Application.WorksheetFunction.Correl(tmp1, tmp2)
End Function

You need determine the max rows count between the two ranges first and then ReDim the arrays to the max count. Declaring the array as a numeric type will prevent you from having to initiate the values to 0.
'Calculate correlation coefficient with whatever sizes of two data sets
Function CorrelationDifferentSizes(data1 As Range, data2 As Range) As Double
Dim arr1() As Double, arr2() As Double, x As Long
Dim Count As Long
Count = Application.WorksheetFunction.Max(data1.Rows.Count, data2.Rows.Count)
ReDim arr1(1 To Count)
ReDim arr2(1 To Count)
For x = 1 To data1.Rows.Count
arr1(x) = data1(x)
Next
For x = 1 To data2.Rows.Count
arr2(x) = data2(x)
Next
CorrelationDifferentSizes = Application.WorksheetFunction.Correl(arr1, arr2)
End Function

Related

Excel VBA, combine 2 sets of data into a single array and remove blank rows

I've been using stackoverflow as a great reference tool for VBA.
I've got 2, 2-column sets of data as shown below.
My goal is to have a user input data into those 2 columns, create a single 2-column array with that info, and remove blank rows from that array, and then create a drop-down containing the info from the first column of the combined array. The second column will be used for voltage references. (the header not being part of the array.)
What i've done is create 2 arrays at first, and combine them. I'm not sure if this is the best method, I need something that will work fast and I'm not sure how to properly remove the rows.
The code is below:
Sub test1()
Dim CombinedArray As Variant
Dim SWGRArray As Variant
Dim MCCArray As Variant
SWGRArray = Sheets("Worksheet").Range(Cells(3, 8), Cells(19, 9)).value
MCCArray = Sheets("Worksheet").Range(Cells(3, 10), Cells(19, 11)).value
CombinedArray = MergeArrays(SWGRArray, MCCArray)
End Sub
Public Function MergeArrays(ParamArray Arrays() As Variant) As Variant
' merges multiple arrays into a single array.
' ParamArray is an array listing other arrays
' Thanks to 'Tom' via https://stackoverflow.com/questions/46051448/excel-vba-joining-two-arrays
Dim i As Long, J As Long, cnter As Long, UBoundArr As Long, OldUBoundArray As Long
Dim arr() As Variant
For J = LBound(Arrays) To UBound(Arrays)
UBoundArr = UBoundArr + UBound(Arrays(J), 1)
Next J
ReDim arr(1 To UBoundArr, 1 To 1)
For J = LBound(Arrays) To UBound(Arrays)
For i = LBound(Arrays(J)) To UBound(Arrays(J))
arr(i + OldUBoundArray, 1) = Arrays(J)(i, 1)
Next i
OldUBoundArray = OldUBoundArray + UBound(Arrays(J), 1)
Next J
MergeArrays = arr
End Function
Stack Arrays
I was about to post this on the 16th, when right in front of my nose the post got deleted. So I'm sorry there are no comments, it was a long time ago.
Option Explicit
Function getStackedArrays(ByVal FirstIndex As Long, _
ParamArray Arrays() As Variant) _
As Variant
' Define Lower-Upper Array.
Dim UB As Long: UB = UBound(Arrays)
Dim LU As Variant: ReDim LU(3)
Dim lub As Variant
Dim i As Long
For i = 0 To 3: ReDim lub(0 To UB): LU(i) = lub: Next i
' Populate Lower-Upper Array and calculate dimensions of Result Array.
Dim uCount As Long, uCurr As Long
Dim lMax As Long, lCurr As Long
For i = 0 To UB
If IsArray(Arrays(i)) Then
GoSub calcIsArray
Else
GoSub calcNotArray
End If
GoSub countnMax
Next i
If lMax = 0 Or uCount = 0 Then Exit Function
' Define Result Array.
Dim UB1 As Long: UB1 = FirstIndex + uCount - 1
Dim UB2 As Long: UB2 = FirstIndex + lMax - 1
Dim Result As Variant: ReDim Result(FirstIndex To UB1, FirstIndex To UB2)
' Populate Result Array.
Dim k As Long, l As Long, m As Long, n As Long
m = FirstIndex
For i = 0 To UB
If IsArray(Arrays(i)) Then
GoSub writeResult
End If
Next i
' Write Result Array to Function Result.
getStackedArrays = Result
Exit Function
' Subroutines
calcIsArray:
If LBound(Arrays(i)) <= UBound(Arrays(i)) Then
LU(0)(i) = LBound(Arrays(i)): LU(1)(i) = UBound(Arrays(i))
On Error Resume Next
LU(3)(i) = LBound(Arrays(i), 2): LU(3)(i) = UBound(Arrays(i), 2)
On Error GoTo 0
End If
Return
calcNotArray:
If Not IsEmpty(Arrays(i)) Then
ReDim lub(0): lub(0) = Arrays(i): Arrays(i) = lub
LU(0)(i) = 0: LU(1)(i) = 0
End If
Return
countnMax:
uCurr = LU(1)(i) - LU(0)(i) + 1: uCount = uCount + uCurr
On Error Resume Next
lCurr = LU(3)(i) - LU(2)(i) + 1
If lCurr > lMax Then lMax = lCurr
On Error GoTo 0
Return
writeResult:
If Not IsEmpty(LU(0)(i)) And Not IsEmpty(LU(2)(i)) Then ' 2D
For k = LU(0)(i) To LU(1)(i)
n = FirstIndex
For l = LU(2)(i) To LU(3)(i)
Result(m, n) = Arrays(i)(k, l)
n = n + 1
Next l
m = m + 1
Next k
Else ' 1D
For k = LU(0)(i) To LU(1)(i)
Result(m, FirstIndex) = Arrays(i)(k)
m = m + 1
Next k
End If
Return
End Function

Store values of 2-dimenssional range (i,j) recalculated N times to a 2-dimensional range (N,i*j)

I have a 2-dimensional range (i, j) like this:
1 2 3 4 5
6 7 8 9 0
I want to copy&paste it to another sheet like this:
1 6 2 7 3 8 4 9 5 0
I need to recalculate the 2-dim range many times and store the results on another sheet, where each row stores one iteration.
Right now I store all calculations in a array (N, i*j) using two for-loops and then paste all itearations on another sheet.
Is there a faster way to do that?
Current code:
Dim a(1 To 100, 1 To 10) As Double
For iter = 1 To 100
Calculate
For i = 1 To 2
For j = 1 To 5
a(iter, i + j * (i - 1)) = Cells(i, j)
Next j
Next i
Next iter
With Sheets("results")
Range(.Cells(1, 1), .Cells(100, 2 * 5)) = a
End With
UPD:
After each "calculate" the values of the initial range change. The example just illustrates how the values from 2-d range should be stored in one row.
UPD2:
Corrected my current code
Something like this should work for you:
Sub tgr()
Dim rData As Range
Dim iter As Long
Dim lNumIterations As Long
Dim i As Long, j As Long, k As Long
Dim a() As Double
Dim aAfterCalc As Variant
Set rData = Sheets("Data").Range("A1:E2")
lNumIterations = 100
ReDim a(1 To lNumIterations, 1 To rData.Rows.Count * rData.Columns.Count)
For iter = 1 To lNumIterations
k = 0
Calculate
aAfterCalc = rData.Value
For j = 1 To rData.Columns.Count
For i = 1 To rData.Rows.Count
k = k + 1
a(iter, k) = aAfterCalc(i, j)
Next i
Next j
Next iter
Sheets("results").Range("A1").Resize(lNumIterations, UBound(a, 2)).Value = a
End Sub
Try this. It gives your desired output and only uses two loops (instead of three)
' For loop
Dim i As Long, j As Long
' Initalise array
Dim tmp(1 To 100, 1 To 10) As Variant
'Loop through all rows in already initalised array
For i = LBound(tmp, 1) To UBound(tmp, 1)
'Calculate to get updated row contents
Calculate
'Loop through each column in row
'The Round and divided by two is to calculate the number of columns concerned instead of the number in the array
For j = LBound(tmp, 2) To Round((UBound(tmp, 2) + 0.1) / 2)
'First row
tmp(i, (j + j - 1)) = Cells(1, j).Value2
'Second row
' If incase the array is initalised to an odd number otherwise this would be out of range
If j * 2 <= UBound(tmp, 2) Then
tmp(i, j * 2) = Cells(2, j).Value2
End If
Next j
Next i
' Write back to sheet
With Sheets("results").Cells(1, 1)
Range(.Offset(0, 0), .Offset(UBound(tmp, 1) - 1, UBound(tmp, 2) - 1)) = tmp
End With
Not sure I get you, but something like this
Sub test()
Dim a() As Variant
Dim b() As Variant
a = Range("a1:e1").Value
b = Range("a2:e2").Value
For x = 1 To 5
Range("H1").Offset(0, x).Value = a(1, x)
Range("H1").Offset(0, 5 + x).Value = b(1, x)
Next x
End Sub
Private Sub this()
Dim this As Variant, counter As Long, that As Integer, arr() As Variant
counter = 0
this = ThisWorkbook.Sheets("Sheet3").UsedRange
For i = LBound(this, 2) To UBound(this, 2)
counter = counter + 2
ReDim Preserve arr(1 To 1, 1 To counter)
arr(1, counter - 1) = this(1, i)
arr(1, counter) = this(2, i)
Next i
ThisWorkbook.Sheets("Sheet4").Range(ThisWorkbook.Sheets("Sheet4").Cells(1, 1), ThisWorkbook.Sheets("Sheet4").Cells(1, counter)).Value2 = arr
End Sub

How to loop through columns and calculate averages?

data series
I want to find the average for each segment of ten values down a column. (See data series picture)
Continuously all the way to the bottom of the data set. The data set can vary in length, and the code has to be "generic" of sorts.
Based on other code segments I have tried to do this:
Sub tenthavg()
Dim currentIndex As Long
Dim myArray() As Variant
Dim rng As Range
ReDim myArray(1 To 10)
Range("b1", Range("b1").End(xlDown)).Select
Set myArray = Selection
currentIndex = 1
Do Until currentIndex + 1 > UBound(myArray)
ActiveSheet.Cells(currentIndex, "T") = AverageOfSubArray(myArray, currentIndex, 10)
currentIndex = currentIndex + 1
Loop
End Sub
'=================================================================
Function AverageOfSubArray(myArray As Variant, startIndex As Long, elementCount As Long) As Double
Dim runningTotal As Double
Dim i As Long
For i = startIndex To (startIndex + elementCount - 1)
runningTotal = runningTotal + val(myArray(i))
Next i
AverageOfSubArray = runningTotal / elementCount
End Function
Unfortunately I can't make it work. Am I approaching this the right way?
If so, what am I doing wrong?
IMHO it's not quite the successful approach ... instead of Selecting EndDown and other concepts borrowed from interactive working make use of VBA's own mechanisms.
A "generic" approch takes Range start address, batch size and offsets where to put the result as arguments ...
Sub AvgX(MyR As Range, S As Integer, ORow As Integer, OCol As Integer)
' MyR = start of range
' S = batch size
' OCol, ORow = Offsets to place result in relation to last batch value
Dim Idx As Integer, Jdx As Integer, RSum As Variant
Idx = 1
RSum = 0
Do
For Jdx = 1 To S
RSum = RSum + MyR(Idx, 1)
Idx = Idx + 1
If MyR(Idx, 1) = "" Then Exit Do
Next Jdx
MyR(Idx - 1, 1).Offset(ORow, OCol) = RSum / (Jdx - 1)
RSum = 0
Loop
End Sub
and is called by
Sub Test()
AvgX [C4], 10, 0, 1
End Sub
to give you this result ...
You can get your result in a simpler way:
Sub tenthavg()
Dim LastRow As Long
LastRow = ThisWorkbook.Sheets("Your Sheet Name").Columns(2).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim myArray(1 To 10) As Double
If LastRow < 10 Then
MsgBox "There's not enough data!"
Else
On Error Resume Next
For x = 1 To LastRow - 9
For y = 1 To 10
myArray(y) = ThisWorkbook.Sheets("Your Sheet Name").Cells(y + x - 1, 2).Value
Next y
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = 0
ThisWorkbook.Sheets("Your Sheet Name").Cells(x, 20).FormulaR1C1 = Application.Average(myArray)
Next x
End If
End Sub
Please note: I'm assuming you're data starts at B1 and you want the output on column T.

Excel VBA function: How to pass range, convert to array, reverse, and return array

I am trying to do some array math in Excel which requires me to reverse a number of 1-dimensional ranges a good amount of times, so I want to write a function for it, rather than create reverses in the spreadsheet.
I have written a reverse() function in VBA but it returns #VALUE! errors in the spreadsheet. This happens no matter array size, nor whether inputting a same size array function or enclosing with a summary function like SUM(). I verified that the reversing logic works as a Sub. This leads me to believe the issue is with passing/returning the range/array but I don't understand what is wrong.
Function reverse(x As Range) As Variant()
' Array formula that reverses a one-dimensional array (1 row, x columns)
Dim oldArray() As Variant, newArray() As Variant
Dim rows As Long: i = x.rows.Count
Dim cols As Long: i = x.Columns.Count
ReDim oldArray(1 To rows, 1 To cols), newArray(1 To rows, 1 To cols)
oldArray = x.Value
newArray = oldArray
For i = 1 To cols / 2 Step 1
newArray(1, i) = oldArray(1, cols - i + 1)
newArray(1, cols - i + 1) = oldArray(1, i)
Next
reverse = newArray
End Function
Keep in mind, I may extend it to reverse 2 dimensional arrays, but that's the trivial part. My question is just trying to ensure the function works on a (1, N) range.
Thanks!
Find below code....
Function reverse(x As Range) As Variant()
' Array formula that reverses a one-dimensional array (1 row, x columns)
Dim oldArray() As Variant, newArray() As Variant
Dim rows As Long
rows = x.rows.Count
Dim cols As Long
cols = x.Columns.Count
ReDim oldArray(1 To rows, 1 To cols), newArray(1 To rows, 1 To cols)
oldArray = x.Value
newArray = oldArray
For i = 1 To cols / 2 Step 1
newArray(1, i) = oldArray(1, cols - i + 1)
newArray(1, cols - i + 1) = oldArray(1, i)
Next
reverse = newArray
End Function
The following code is more versatile, it use optional arguments to determine if rows, columns or both (or none) should be reversed. By default it will reverse columns.
Function ReverseRange(Source As Range, Optional ReverseRows As Boolean = False, Optional ReverseColumns As Boolean = True) As Variant()
Dim SourceArray() As Variant
Dim DestArray() As Variant
SourceArray = Source.value
Dim nRows As Long, nColumns As Long
nRows = UBound(SourceArray, 1)
nColumns = UBound(SourceArray, 2)
ReDim DestArray(1 To nRows, 1 To nColumns)
Dim r As Long, r2 As Long, c As Long, c2 As Long
For r = 1 To nRows
r2 = IIf(ReverseRows, nRows - r + 1, r)
For c = 1 To nColumns
c2 = IIf(ReverseColumns, nColumns - c + 1, c)
DestArray(r2, c2) = SourceArray(r, c)
Next c
Next r
ReverseRange = DestArray
End Function
Note that there is no verification on the range validity.
This will reverse the columns in the range no matter the row count.
Function reverse(Source As Range) As Variant()
Dim Data, RevData
Dim x As Long, y As Long, y1 As Long
Data = Source.Value
ReDim RevData(1 to UBound(Data, 1),1 to UBound(Data, 2))
For x = 1 To UBound(Data, 1)
y1 = UBound(Data, 2)
For y = 1 To UBound(Data, 2)
RevData(x, y1) = Data(x, y)
y1 = y1 - 1
Next
Next
reverse = RevData
End Function

Excel VBA transfer two dimensional array to one dimension

I'm not mathemathics, but I need to solve some mapping function in VBA.
I have string array Divisions, which is filled by checked checkboxes on form (array is filled by string or zero, like on picture). I need to found some function which converts my array (on left, always 3x4 dimension) to array on right (nx1 dimension). Here are examples:
Do you have any ideas? Does it exists some kind of map function in VBA, which can do, what I wish? Thank you
3 simple loops will do:
Option Explicit
Option Base 1
Sub Test()
Dim arr, vec() As String, dmy As String
Dim r1 As Integer, r2 As Integer, r3 As Integer, counter As Integer
arr = Range("A1:D3").Value
For r1 = 1 To 4
For r2 = 1 To 4
For r3 = 1 To 4
dmy = Join(Array(arr(1, r1), arr(2, r2), arr(3, r3), " "))
If InStr(dmy, "0") = 0 Then
counter = counter + 1
ReDim Preserve vec(counter)
vec(counter) = dmy
End If
Next
Next
Next
Range("G1").Resize(counter, 1).Value = Application.WorksheetFunction.Transpose(vec)
End Sub
Unfortunately, I do not think that there's such a function. You will have to write it yourself.
Alternatively, you can take a look here http://www.cpearson.com/excel/vbaarrays.htm
edited after OP's clarifications
you could go like follows:
Option Explicit
Sub main()
Dim myMatrix(1 To 3, 1 To 4) As Variant
Dim myArray As Variant
Dim i As Long, j As Long, k As Long, nRows As Long, nCols As Long
'fill Matrix with some values
myMatrix(1, 1) = 1: myMatrix(1, 2) = 2: myMatrix(1, 3) = 3: myMatrix(1, 4) = 4
myMatrix(2, 1) = 5: myMatrix(2, 2) = 6: myMatrix(2, 3) = 7: myMatrix(2, 4) = 8
myMatrix(3, 1) = 9: myMatrix(3, 2) = 10: myMatrix(3, 3) = 11: myMatrix(3, 4) = 12
myArray = GetArray(myMatrix) '<~~ fill Array
MsgBox GetArrayItem(myArray, 2, 3) '<~~ get Array item corresponding to Matrix(2,3)
MsgBox GetMatrixItem(myMatrix, 7) '<~~ get Matrix item corresponding to Array(7)
End Sub
Function GetArrayItem(myArray As Variant, i As Long, j As Long) As Variant
'mapping from Matrix to array
Dim k As Long
k = (i - 1) * 4 + j '<~~ equivalent array index given matrix indexes
GetArrayItem = myArray(k)
End Function
Function GetMatrixItem(myMatrix() As Variant, k As Long) As Variant
'mapping from Array to Matrix
Dim i As Long, j As Long, nCols As Long
nCols = UBound(myMatrix, 2) - LBound(myMatrix, 2) + 1 '<~~get Matrix columns number
i = k Mod nCols - 1 '<~~ matrix row index given array index
j = k - (i - 1) * nCols '<~~ matrix column index given array index
GetMatrixItem = myMatrix(i, j)
End Function
Function GetArray(myMatrix() As Variant) As Variant
'returns an Array filled with a Matrix content
Dim myArray() As Variant
Dim i As Long, j As Long, k As Long, nRows As Long, nCols As Long
nRows = UBound(myMatrix, 1) - LBound(myMatrix, 1) + 1 '<~~get Matrix rows number
nCols = UBound(myMatrix, 2) - LBound(myMatrix, 2) + 1 '<~~get Matrix columns number
ReDim myArray(1 To nRows * nCols) '<~~dim Array accordingly to Matrix dimensions
'loop through Matrix elements to fill Array
For i = 1 To nRows
For j = 1 To nCols
myArray((i - 1) * 4 + j) = myMatrix(i, j)
Next j
Next i
GetArray = myArray '<~~return array
End Function
Almost equal to Jochen's Answer. Here i check if the element of the array is non-zero and then combine them to check length of the string. If it is equal to 3 then print it otherwise continue.
Option Explicit
Sub test()
Dim base(2, 3), ip As Range, op As Range, output(64), i As Integer, j As Integer, k As Integer, l As Integer, temp As String
l = 0
Set ip = Application.InputBox(Prompt:="Please select a first cell of input range", Title:="Specify Input range", Type:=8)
Set op = Application.InputBox(Prompt:="Please select a first cell of output range", Title:="Specify Output range", Type:=8)
For i = 0 To 2
For j = 0 To 3
base(i, j) = ip.Offset(i, j).Value
Next j
Next i
For i = 0 To 3
If base(0, i) <> 0 Then
For j = 0 To 3
If base(1, j) <> 0 Then
For k = 0 To 3
If base(2, k) <> 0 Then
temp = base(0, i) & base(1, j) & base(2, k)
If Len(temp) = 3 Then
output(l) = temp
op.Offset(l, 0) = output(l)
l = l + 1
temp = ""
End If
End If
Next k
End If
Next j
End If
Next i
End Sub

Resources