I've played around with this for several hours and am no closer to a solution.
When I create an array the following way, it outputs to a range without any difficulties:
Dim Destination As Range
Set Destination = NewSheet.Range("A1")
ReDim OutArray(1 To 1, 1 To NumArrayCols) As Variant
OutArray(1, 1) = "hello"
Destination.Resize(UBound(OutArray, 1), UBound(OutArray, 2)).Value = OutArray
However, when I create an output array in the following manner, it simply pastes a big blank array onto my spreadsheet. The first section of the code is probably mostly irrelevant, but I want to include it in case I'm missing anything:
ReDim OutArray(1, 1 To NumArrayCols) As Variant
Set ThisAtt = Wells.CurrWell.FirstAttribute(Skip:=False)
k = 1
OutArray(1, k) = "UWI"
Do
ElevOffset = 0
Set ThisAtt = Wells.CurrWell.CurrAttribute
If InStr(LCase(ThisAtt.Name1), "elevation") Then
OutArray(1, k + 1) = ThisAtt.Name1
OutArray(1, k + 2) = ""
OutArray(1, k + 3) = ThisAtt.Name2
OutArray(1, k + 4) = ""
ElevOffset = ElevOffset + 2
Else
OutArray(1, k + 1) = ThisAtt.Name1
OutArray(1, k + 2) = ThisAtt.Name2
End If
OutArray(1, k + ElevOffset + 3) = "Recommend"
OutArray(1, k + ElevOffset + 4) = "Rec. Value"
OutArray(1, k + ElevOffset + 5) = "Comments"
k = k + ElevOffset + 2 + AdditionalColumns
Loop While Not (Wells.CurrWell.NextAttribute(EnableSkipping:=False) Is Nothing)
Dim Destination As Range
Set Destination = NewSheet.Range("A1")
Destination.Resize(UBound(OutArray, 1), UBound(OutArray, 2)).Value = OutArray
It's strange, because every element in OutArray, upon inspection, seems to be there. My hand-generated array works fine, but the automatically-generated array--which seems similar in almost every way--doesn't work. Anyone know why?
I suspect that it is just your REDIM statements. In your first example you have this:
ReDim OutArray(1 To 1, 1 To NumArrayCols) As Variant
but in the second example you do this:
ReDim OutArray(1, 1 To NumArrayCols) As Variant
Notice the difference? When you say ReDim A(1 To 1) both the upper and lower bounds are 1, but when you say just Redim(1) only the upper bound is 1, the lower bound is set to the default, which is zero (0). Thus the two arrays are not the same shape/size and therefore in your second case your array does not fit correctly into the Destination Range.
Related
With some 20K observations, the following code takes some 7.5 sec to run
'Remember time when macro starts
StartTime = Timer
For i = 2 To UBound(avTransposed, 2)
For J = 1 To UBound(avTransposed, 1)
k = IIf(J = 1, k + 1, k)
' If J = 1 Then k = k + 1
ReDim Preserve TrueUsedRangeArray(1 To Dim2, 1 To k)
TrueUsedRangeArray(J, k) = avTransposed(J, i)
Next
Next
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
Without the
k = IIf(J = 1, k + 1, k) line (or If J = 1 Then k = k + 1), it takes less than one sec!!
Any idea?
The ReDim Preserve is probably killing performance. Every time it is used, it creates a new array and copies the existing array in.
You can work out up-front the size of TrueUsedRangeArray, something like the following
ReDim TrueUsedRangeArray(1 To Ubound(avTransposed, 2), 1 To Ubound(avTransposed, 1))
Too many things in your inner loop which do not need to be there:
For i = 2 To UBound(avTransposed, 2)
k = k + 1
ReDim Preserve TrueUsedRangeArray(1 To Dim2, 1 To k)
For J = 1 To UBound(avTransposed, 1)
TrueUsedRangeArray(J, k) = avTransposed(J, i)
Next
Next
As Patrick notes though, you do not need the redim preserve in the loop, since you already know the final size of TrueUsedRangeArray from the dimensions of avTransposed
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 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 would appreciate some help on the following VBA Macro problem,
screenshot here:
I have to compare the data in 2 columns - Index & Sec_Index. In case of a match it should check which Values is assigned to the Sec_Index and fill a "1" to the matching Value column corresponding to Index and "0" for the other Value columns (I hope the screenshot explains it better)
I wrote a short macro which works good. However I have huge amounts of data - both Index columns contain at least 400000-500000 lines. This makes my code useless since it will take extreme long durations to execute.
Is there a way to make this work? I read about Variant arrays, but I'm not that familiar with them.
You can put this formula (if Excel 2007 or above):
=COUNTIFS($H$2:$H$5,$B2,$I$2:$I$5,"A")
into C2 and copy it down and across; just change "A" to "B" and "C".
Added In view of the number of rows, I would import the data into MS Access, create a Crosstab Query, then copy this data back to Excel.
Try this, not overly robust but does work. Not sure how quickly this will compare to what you may have had?
It did about 60,000 rows with 25 keys in about 5 seconds.
Edit: Added timer to function.
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
public Sub main()
Dim t As Long
t = GetTickCount
Application.ScreenUpdating = False
Dim Arr1(), Arr() As Double
Dim x, y, i, j As Double
Dim v As String
x = Cells(Rows.Count, 2).End(xlUp).Row - 2
y = Cells(Rows.Count, 8).End(xlUp).Row - 2
Range("c2", "e" & x + 2) = 0
ReDim Arr1(x)
ReDim Arr2(y)
i = 0
Do Until Cells(i + 2, 2) = ""
Arr1(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until Cells(i + 2, 8) = ""
Arr2(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until i > UBound(Arr1)
j = 0
Do Until j > UBound(Arr2)
If Arr1(i) = Arr2(j) Then
v = Cells(Arr2(j) + 1, 9)
Select Case v
Case "a"
Cells(i + 2, 3) = 1
Case "b"
Cells(i + 2, 4) = 1
Case "c"
Cells(i + 2, 5) = 1
End Select
Exit Do
End If
j = j + 1
Loop
i = i + 1
Loop
MsgBox GetTickCount - t, , "Milliseconds"
End Sub
So i have this number of different two dimensional arrays that contain different physical attributes of a flow (mach number, temperature, etc). i need to plot these values in excel and calculate different averages. these arrays are declared globally. To do this i used to write one subroutine for each array but its not a good way, because you should keep it as general as possible right?
so what i end up with is: the subroutine is passed the arrays and the corresponding worksheet...
or use pointers? would also be interesting to know how you would solve this in other more advanced programming languages (C++,..) since vba is not quite my weapon of choice but in this case its necessary.
It errors with a "Type mismatch: Array or user-defined type expected!"
When i call i use:
Call WriteFlowVariable(ws_meridian_velocity, MeridSpeed(), average_MeridSpeed(), area_average_MeridSpeed(), mass_average_MeridSpeed())
This is the Subroutine:
Sub WriteFlowVariable(ws As Worksheet, FlowVariable() As Double, average_FlowVariable() As Double, area_average_FlowVariable(), mass_average_FlowVariable())
Dim i As Integer
Dim j As Integer
Dim sum_v As Double
Dim FlowVariabledeltaA(1000, 300) As Double
Dim FlowVariabledeltaA_added(1000) As Double
Dim FlowVariabledeltaM(1000, 300) As Double
Dim FlowVariabledeltaM_added(1000) As Double
'write titles of the charts
ws.Cells.Clear
For j = 0 To SecNumber - 1
ws.Cells(1, j + 2).value = (j + 1)
Next j
ws.Cells(1, SecNumber + 2) = "Arithmetic Average"
ws.Cells(1, SecNumber + 3) = "Area Average"
For i = 0 To number_of_axial_positions - 1
sum_v = 0
'Write section number
ws.Cells(i + 2, 1).value = i + 1
'Write value and calculate arithmetic, mass and area average
For j = 0 To SecNumber - 1
ws.Cells(i + 2, j + 2).value = FlowVariable(i, j)
sum_v = sum_v + FlowVariable(i, j)
If j < SecNumber - 1 Then
FlowVariable(i, j) = FlowVariable(i, j) * deltaA(i, j)
FlowVariabledeltaA_added(i) = FlowVariabledeltaA_added(i) + FlowVariabledeltaA(i, j)
FlowVariabledeltaM(i, j) = FlowVariable(i, j) * deltaM(i, j)
FlowVariabledeltaM_added(i) = FlowVariabledeltaM_added(i) + FlowVariabledeltaM(i, j)
End If
Next j
average_FlowVariable(i) = sum_v / SecNumber
'Write arithmetic average to the third last column
ws.Cells(i + 2, SecNumber + 2) = average_FlowVariable(i)
area_average_FlowVariable(i) = FlowVariabledeltaA_added(i) / crosssectionareaInput(i)
'Write area average to the second last column
ws.Cells(i + 2, SecNumber + 3) = area_average_FlowVariable(i)
mass_average_FlowVariable(i) = FlowVariabledeltaM_added(i) / crosssectionareaInput(i)
'Write mass average to the last column
ws.Cells(i + 2, SecNumber + 4) = mass_average_FlowVariable(i)
Next i
End Sub
I didn't examine your Sub too closely at all, but assuming
FlowVariable(,) As Double
average_FlowVariable(,) As Double
area_average_FlowVariable(,)
mass_average_FlowVariable(,)
are all declared correctly to be considered global variables, your call should look as follows:
Call WriteFlowVariable(ws_meridian_velocity, MeridSpeed, average_MeridSpeed, area_average_MeridSpeed, mass_average_MeridSpeed)
... In other words, remove the ().
Also, since these are 2-D arrays, your Sub should look as follows:
Sub WriteFlowVariable(ws As Worksheet, FlowVariable(,) As Double, average_FlowVariable(,) As Double, area_average_FlowVariable(,), mass_average_FlowVariable(,))Dim i As Integer
Hope this does the trick, otherwise, lemme know and I'll look closer.