I am manually transposing a large array from a recordset (.transpose did not work) but the first column is missing. Can anyone tell me where I went wrong
Dim FinalArr As Variant
ReDim FinalArr(1 To UBound(ArrRs1, 2), 1 To UBound(ArrRs1, 1))
For i = 1 To UBound(ArrRs1, 2)
For j = 1 To UBound(ArrRs1, 1)
FinalArr(i, j) = ArrRs1(j, i)
Next
Next
The array had a lower bound of 0.
Dim PasteArray As Variant
ReDim PasteArray(1 To UBound(ArrRs1, 2), 0 To UBound(ArrRs1, 1))
For i = 1 To UBound(ArrRs1, 2)
For j = 0 To UBound(ArrRs1, 1)
PasteArray(i, j) = ArrRs1(j, i)
Next
Next
Related
I am trying to gather data from dozens of worksheets in a workbook and compile them all to be appended to a new master workbook.
This line: ReDim varArray2 (1 To UBound(varArray, 2), 1 To UBound(varArray, 1)) keeps clearing out my preserved data from all worksheets when I try to make an overarching varArray2 to print all arrays at once to the new master worksheet.
What is causing the array to clear out and how can I fix it?
Option Explicit
Sub ws_Merge()
Dim k As Long, x As Long, j As Long
Dim varArray() As Variant
Dim varArray2() As Variant
ReDim varArray(1 To 11, 1 To 1)
Dim ws As Worksheet, wb As Workbook
Set wb = ThisWorkbook
For Each ws In Worksheets
With wb.ActiveSheet
For j = 2 To .UsedRange.Rows.Count + 1
If .Cells(j, 1) <> "" Then
x = x + 1
ReDim Preserve varArray(1 To UBound(varArray, 1), 1 To x)
For k = 1 To UBound(varArray, 1)
varArray(k, x) = .Cells(j, k)
Next
End If
Next
End With
Next ws
ReDim varArray2(1 To UBound(varArray, 2), 1 To UBound(varArray, 1))
With ThisWorkbook.Sheets.Add
For j = 1 To UBound(varArray, 2)
For k = 1 To UBound(varArray, 1)
varArray2(j, k) = varArray(k, j)
Next
Next
.Range(.Cells(2, 1), .Cells(UBound(varArray, 2), UBound(varArray, 1))) = varArray2
End With
End Sub
I want to combine arrays in my program. Take those as an example:
a = {1,2,3,4,5}
b = {6,7,8,9,10}
This should produce an array containing first element of first array with all elements of second array except first element, which is {1,7,8,9,10}. This should continue for all possible combinations, producing these output arrays:
{1,7,8,9,10} {6,2,8,9,10} {6,7,3,9,10} {6,7,8,4,10} {6,7,8,9,5}...
For 2,3,4 elements of first array with second array
{1,2,8,9,10} {6,2,3,9,10} {6,7,3,4,10} {6,7,8,4,5} {1,7,8,9,5}...
{1,7,3,9,10} {6,2,8,4,10} {6,7,3,9,5} {1,7,8,4,10}.....
and vice versa for second array.
For the first combination I've tried:
For I = 0 To 4
'first array loop
For J = 0 To 4
'second array loop
If I <> J Then
arr(J) = arr2(J)
Else
arr(J)=arr1(J)
End If
Next
Next
This will give you every combination possible:
Function fifth(ParamArray arr() As Variant) As Variant()
Dim temp() As Variant
Dim i As Long
Dim j As Long
Dim t As Long
For i = LBound(arr) + 1 To UBound(arr)
If UBound(arr(LBound(arr))) <> UBound(arr(i)) Then
MsgBox "Arrays not same size"
Exit Function
End If
Next i
ReDim temp(1 To (UBound(arr) + 1) ^ (UBound(arr(LBound(arr))) + 1), LBound(arr(LBound(arr))) To UBound(arr(LBound(arr)))) As Variant
For i = 1 To (UBound(arr) + 1) ^ (UBound(arr(LBound(arr))) + 1)
For j = 1 To (UBound(arr(LBound(arr))) + 1)
t = Int((i Mod ((UBound(arr) + 1) ^ j)) / (((UBound(arr) + 1) ^ j) / (UBound(arr) + 1)))
temp(i, j - 1) = arr(t)(j - 1)
Next j
Next i
fifth = temp
End Function
You would call thus:
Sub ArrCombine()
Dim arr1() As Variant
Dim arr2() As Variant
Dim rsltarr() As Variant
arr1 = Array(1, 2, 3, 4, 5)
arr2 = Array(6, 7, 8, 9, 10)
rsltarr = fifth(arr1, arr2)
ActiveSheet.Range("A1").Resize(UBound(rsltarr, 1), UBound(rsltarr, 2) + 1).Value = rsltarr
End Sub
It will output on the active sheet, this:
This also has the advantage of being dynamic. You can use more than two arrays. The only rule is that they need to have the same number of values.
The only other limit is the number of rows on a worksheet. So (number of arrays) ^ (number of values) cannot exceed 2^20.
I tried putting the program into VBA, but I keep getting an error. This line was highlighted:
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)
I am trying to multiply two of the same matrices and then add it to itself.
Suppose I wanted to multiply a 15 x 15 matrix, would I use the same codes except just change the dimensions and ranges?
Sub testing()
Dim A As Variant
Dim B(1 To 2, 1 To 2)
Dim C(1 To 2, 1 To 2)
A = Range("A1:B2").Value
i = 1
C(1, 1) = 0
Do Until i = 3
j = 1
Do Until j = 3
C(i, j) = C(i, j) + A(i, j) * A(j, i)
**B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1)**
j = j + 1
Loop
i = i + 1
Loop
Range("E1:F2").Value = B
End Sub
Thanks!
Do...Loop is not the right tool for this job. Use For...Next instead. Also, to help make sure you don't overrun the array bounds and get a subscript out of range error, you can use LBound and UBound instead of hard-coding the index bounds. That way you don't have to change the code if you change the size of your input matrix.
This will get you part of the way. For simplicity I assumed A is a square matrix.
Dim i As Long, j As Long
Dim A As Variant
Dim B() As Variant
Dim C() As Variant
A = Range("A1:B2").Value
ReDim B(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
ReDim C(LBound(A, 1) To UBound(A, 1), LBound(A, 2) To UBound(A, 2))
For i = LBound(A, 1) To UBound(A, 1)
For j = LBound(A, 2) To UBound(A, 2)
C(i, j) = C(i, j) + A(i, j) * A(j, i)
B(i, j) = C(i, j) + A(i + 1, j) * A(i, j + 1) ' still bad
Next j
Next i
Now you'll still get an error on that same line, due to the i+1 and j+1 indices. Those will have a value of 3 at some point, which is beyond your array bounds of 2. I can't help you fix that line, because I don't understand what you are trying to do with it.
Which brings me to my next point: if you think you're doing a matrix multiplication with this line
C(i, j) = C(i, j) + A(i, j) * A(j, i)
then you are wrong. The correct definition is:
and this is not what you have implemented.
A perhaps more convenient way to do it is to use the built-in MMult function:
C = WorksheetFunction.MMult(A, A)
I have a serious problem with resizing a 2-dimensional array in VBA. I've done a lot of reading about this (popular) issue, but still I can't figure out what's wrong in my code.
So, I have some data in a spreadsheet. In the second row I have some descriptions of an element, while in the first row I have categories of those elements. What I want to do is create an array which has (distinct) categories in the first row and indexes of descriptions related to a particular category in the second row.
The code works correctly up until
If j = UBound(distinctList, 2) Then
Then ReDim comes in and I get a "Subscript out of range error".
That If is there to add a new category and is meant to kick in if the entry from the spreadsheet does not equal any entry from the new array.
Function distinctValues(arr)
Dim distinctList() As String
Dim j As Integer
k = 0
'ReDim distinctList(0 To 0, 0 To 1)
'Dodaj pierwszy wpis
For i = LBound(arr) To UBound(arr)
If arr(i) <> "" Then
ReDim distinctList(0 To 1, 0 To j)
distinctList(0, 0) = arr(i)
distinctList(1, 0) = i + 1
'k = k + 1
Exit For
End If
Next i
'Dodaj kolejne wpisy
For i = LBound(arr) + 1 To UBound(arr)
If arr(i) <> "" Then
For j = LBound(distinctList, 2) To UBound(distinctList, 2)
If arr(i) = distinctList(0, j) Then
distinctList(1, j) = distinctList(1, j) & ", " & i + 1
'k = k + 1
Exit For
End If
If j = UBound(distinctList, 2) Then
ReDim Preserve distinctList(0 To 1, 1 To UBound(distinctList, 2) + 1)
distinctList(0, j) = arr(i)
distinctList(1, j) = distinctList(UBound(distinctList, 2), 1) & ", " & i + 1
Exit For
End If
Next j
End If
Next i
Debug.Print distinctList(0, 0) & " => " & distinctList(1, 0)
'distinctValues = distinctList
End Function
It's because you can't change the lower bound of the second dimension, you need to keep it the same..
You declare ReDim distinctList(0 To 1, 0 To j) at the top
when you redim, you need to keep lower bound of the second dimension at 0
ReDim Preserve distinctList(0 To 1, 0 To UBound(distinctList, 2) + 1)
I think you could implement this general solution to your particular solution if you apply this code to change the nr. of dimensions before you add the/a new category.
Option Explicit
Public Sub redimarray()
'This sub redimensions an array as an array of arrays, so to acces the k'th element in the n-th dimension you need to type: my_array(n)(k)
'and you can still simply redefine the array dimensions by:
'my_array =FlexArray("lower_bound_n-th_dim,lower_bound_n-th_dim,_n+1-th_dim,upper_bound_n-th_dim,_n+1-th_dim) = e.g.: FlexArray("2,3,9,11")
'if you then want to have conventional array element conventional_array(3,4) you can copy the entire my_array into a 1 dimensional array where
' the array elements are added like a (nr-of_elements_per_dimension)-base numbering system. once they have been manipulated, you can store them back into
'nr of elements per dimension:
'dim 0 = 4, 0-3
'dim 1 = 3, 4-6
'dim 2 = 8, 1-8
'nr of elements in 1dim array = 4*3*8 = 96
'(0)(4)(1)
'(0)(4)(2)
'...
'(0)(4)(8)
'(0)(5)(1)
'so working_array(3,5,2) = (3-0)*nr_elem(dim 1)*nr_elem(dim 2)+(5-4)*nr_elem(dim 2)+(2-1)
'dim 0 = nr_elements(0), start_element(0)-end_element(0)
'dim 1 = nr_elements(1), start_element(1)-end_element(1)
'dim 2 = nr_elements(2), start_element(2)-end_element(2)
'so working_array(3,5,2) = (end_element(0)-start_element(0))*nr_elements(1)*nr_elements(2)+(end_element(1)-start_element(1))*nr_elements(2)+'so working_array(3,5,2) = (end_element(0)-start_element(0))*nr_elements(1)*nr_elements(2)+(end_element(2)-start_element(2))=index in 1 dimensional array.
Dim NewArray() As Variant
NewArray = FlexArray("1,2,3,8,2,9")
'NewArray = FlexibleArray("1,2,3,8,2,9")
MsgBox (NewArray(1)(8))
End Sub
Public Function FlexArray(strDimensions As String) As Variant
Dim arrTemp As Variant
Dim varTemp As Variant
Dim varDim As Variant
Dim intNumDim As Integer
Dim iDim As Integer
Dim iArr As Integer
varDim = Split(strDimensions, ",")
intNumDim = (UBound(varDim) + 1) / 2
' Setup redimensioned source array
ReDim arrTemp(intNumDim)
iArr = 0
For iDim = LBound(varDim) To UBound(varDim) Step 2
ReDim varTemp(varDim(iDim) To varDim(iDim + 1))
arrTemp(iArr) = varTemp
iArr = iArr + 1
Next iDim
FlexArray = arrTemp
End Function
I'm trying to create a varcov matrix using VBA but despite hours of trying to track down the answer to this problem have been unable to solve it. My problem is that I keep getting the run-time error '9' on each of the below double-asterisked lines:
Sub varcovmmult()
Dim returns()
Dim trans()
Dim Excess()
Dim MMult()
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
'Calculate mean, trans and excess arrays for dimensionalisation
'For mean:
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
For j = 1 To ColCount
**returns(j) = Application.Average(Range("C6:H15").Columns(j))
Range("c30:h30").Cells(j) = returns(j)**
Next j
'For excess:
For j = 1 To ColCount
For i = 1 To RowCount
**Excess(i, j) = Range("c6:h15").Cells(i, j) - returns(j)
Range("C36:H45").Cells(i, j) = Excess(i, j)**
Next i
Next j
'For tranpose:
For j = 1 To ColCount
For i = 1 To RowCount
**trans(j, i) = Range("C36:H45").Cells(i, j)
Range("C51:L56").Cells(j, i) = trans(j, i)**
Next i
Next j
'inject values into product array
For i = 1 To ColCount
For j = 1 To ColCount
For k = 1 To RowCount
**MMult(i, j) = MMult(i, j) + trans(i, k) * Excess(k, j)**
Next k
Next j
Next i
'output product array values into varcov matrix and divide by n.years
For i = 1 To ColCount
For j = 1 To ColCount
**Range("C62").Cells(i, j) = MMult(i, j)**
Next j
Next i
End Sub
You need to put these lines:
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
After these lines:
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
I am trying to run the following code with value 1 in each cell in Range(C6:H15):
Sub varcovmmult()
Dim returns()
Dim trans()
Dim Excess()
Dim MMult()
ColCount = Range("C6:H15").Columns.Count
RowCount = Range("C6:H15").Rows.Count
ReDim trans(ColCount, RowCount)
ReDim Excess(RowCount, ColCount)
ReDim MMult(ColCount, ColCount)
ReDim returns(ColCount)
For j = 1 To ColCount
returns(j) = Application.Average(Range("C6:H15").Columns(j))
Range("c30:h30").Cells(j) = returns(j)
Next j
For j = 1 To ColCount
For i = 1 To RowCount
Excess(i, j) = Range("c6:h15").Cells(i, j) - returns(j)
Range("C36:H45").Cells(i, j) = Excess(i, j)
Next i
Next j
For j = 1 To ColCount
For i = 1 To RowCount
trans(j, i) = Range("C36:H45").Cells(i, j)
Range("C51:L56").Cells(j, i) = trans(j, i)
Next i
Next j
For i = 1 To ColCount
For j = 1 To ColCount
For k = 1 To RowCount
MMult(i, j) = MMult(i, j) + trans(i, k) * Excess(k, j)
Next k
Next j
Next i
For i = 1 To ColCount
For j = 1 To ColCount
Range("C62").Cells(i, j) = MMult(i, j)
Next j
Next i
End Sub
I am successfully able to run this code.
One error that I get was Type mismatch if value in any cell in this range is blank or non-numeric.
If you're getting subscript out of range then you may try using ColCount - 1 or RowCount - 1. Just check if appropriate value exists in Cell(i, j).
Hope this helps!
Vivek