I have two functions in VBA. Function1 returns a 1D array. Then I have function2 which is a multidimensional array. I would like to copy the array in Function1 to the columns of the multidimensional array starting at index 1.
arr2(0,0) = "Something"
arr2(0,1) = ("Something",arr1(0))
arr2(0,2) = ("Something",arr1(1))
This is what I have. arr1 is GetRecData and arr2 is AllChannelsData.
For i = 0 To UBound(channelList)
'the first row in the array is the channels names
AllChannelsData(i, 0) = channelList(i)
Set RecChannel = Rec.FindChannel(channelList(i), RecDevice.Name)
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, 0)
Next
Next
Thanks!
please refer the code below.
Sub Array_test()
Dim GetRecData(9) As String
Dim AllChannelsData(9, 2) As String
For i = 0 To 9
GetRecData(i) = i
For j = 0 To 9
AllChannelsData(j, 0) = j
AllChannelsData(j, 1) = GetRecData(j)
Next j
Next i
End Sub
Change this:
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, 0)
Next
to this
For j = 0 To total_time
AllChannelsData(i, j + 1) = RecChannelData.GetRecData(RecChannel, 1, j)
Next
maybe?
I'm assuming the third parameter of the .GetRecData(RecChannel, 1, 0) method is the index since 1D arrays like you're describing don't take 3 parameters. If that's not it, you may need to expand on what the GetRecData method is/does/returns/etc.
this "base" code works
Option Explicit
Sub main()
Dim arr1 As Variant
Dim arr2() As Variant
Dim total_time As Integer, i As Integer, j As Integer
total_time = 4
ReDim arr2(0 To 3, 0 To total_time)
For i = 0 To 3
arr2(i, 0) = i
For j = 1 To total_time
arr2(i, j) = GetRecData(j + 1)
Next j
Next i
End Sub
Function GetRecData(n As Integer) As Variant
ReDim arr(0 To n - 1) As Variant
Dim i As Integer
For i = 1 To n
arr(i - 1) = i
Next i
GetRecData = arr
End Function
just adapt it to your needs
Related
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
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
I have an array that I preallocate a bunch of memory before populating, once populate i would like to remove the empty rows at the end, however I get an error. Any suggestions of a good way to do this, without using a second for loop?
Dim myArray() as Variant
ReDim myArray( 1 to 800, 1 to 50)
For i = 1 to 800
' .....fill the array
Next i
Then the next following funcition call fails
ReDim Preserve myArray(1 to 50, 1 to 50)
with the error message:
"Run- time error '9':
Subscript out of range"
You can use Redim Preserve in order to redimension an array. However, this will only work for the last dimension of the array. Here a quick example of doing a redim preserve:
Sub Test()
Dim arrMy()
ReDim arrMy(1 To 10, 1 To 10)
Dim i, j
For i = 1 To 10
For j = 1 To 10
arrMy(i, j) = 1
Next j
Next i
ReDim Preserve arrMy(1 To 10, 1 To 1)
End Sub
In order to sidestep this limitation you can simply create a new array, size it appropriately, and fill it using the data from the first array.
Here is an example of this:
Sub Test2()
Dim arrMy()
ReDim arrMy(1 To 10, 1 To 10)
Dim i, j
For i = 1 To 10
For j = 1 To 10
arrMy(i, j) = 1
Next j
Next i
Dim arrFinal()
ReDim arrFinal(1 To 2, 1 To 10)
For i = 1 To 2
For j = 1 To 10
arrFinal(i, j) = arrMy(i, j)
arrFinal(i, j) = arrMy(i, j)
arrFinal(i, 2) = arrMy(i, j)
Next j
Next i
End Sub
This is not a proper answer to your question, but with regard to avoiding loops, you can experiment with this approach
Sub Test2()
Dim arrMy()
ReDim arrMy(1 To 5, 1 To 5)
Dim i, j
For i = 1 To 5
For j = 1 To 5
arrMy(i, j) = i * j
Next j
Next i
Range("A1").Resize(5, 5) = arrMy
Dim arrFinal()
ReDim arrFinal(1 To 2, 1 To 5)
arrFinal = Application.Index(arrMy, Evaluate("ROW(1:2)"), Array(1, 2, 3, 4, 5))
Range("H1").Resize(2, 5) = arrFinal
End Sub
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
I'm trying to assign a 2D array of size 183x6 to a new sheet, populating the blank cells from A1:G182 with the values of the array. For reference, my array is called "Directory" and the empty sheet I want to populate is called "List".
I've tried two different approaches, one by explicitly assigning the specified range to the array as such:
Worksheets("List").Range(Cells(1,1), Cells(UBound(Directory, 1) + 1, UBound(Directory, 2) + 1)) = Directory
And also by trying to iterate through each entry in the array:
For i = 0 To UBound(Directory, 1)
For j = 0 To UBound(Directory, 2)
Worksheets("List").Range(Cells(i + 1, j + 1), Cells(i + 1, j + 1)) = Directory(i,j)
Next j
Next i
In both cases, I get the error:
Run-time error '1004':
Application-defined or object defined error.
Any ideas what could be happening? I appreciate your help.
Try:
Worksheets("List").Range("A1").Resize(UBound(Directory, 1) + 1, UBound(Directory, 2) + 1).Value = Directory
Or:
For i = 0 To UBound(Directory, 1)
For j = 0 To UBound(Directory, 2)
Worksheets("List").Range(Worksheets("List").Cells(i + 1, j + 1), Worksheets("List").Cells(i + 1, j + 1)) = Directory(i,j)
Next j
Next i
You don't need any loops to move an array to memory. For example:
Sub Array2Range()
Dim Directory(1 To 182, 1 To 6) As Variant
Dim rng As Range, i As Long, j As Long
For i = 1 To 6
For j = 1 To 182
Directory(j, i) = i * j
Next j
Next i
Set rng = Sheets("List").Range("A1:F182")
rng = Directory
End Sub
will produce: