Excel VBA transfer two dimensional array to one dimension - arrays

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

Related

VBA Compare Arrays different in size and build a new one

I have a one-dimension array generated by a listbox of strings I would like to use to match with master 2D array with strings in the first column and numbers in all others. The objective is to create a third array with matching strings and the relevant data from the master. Could not find a better solution from searching here although the subjected is not unknown. Guess I am lost in building the new array.
Private Sub ImportSelection()
Dim i, j, k, m, ListSize As Integer
Dim arr2() As String
Dim pArr As variant
Dim Size As Integer
Size = List2.ListCount
ReDim ListBoxContents(0 To Size) As String
For i = 1 To Size
ListBoxContents(i) = List2.list(i)
Next i
On Error GoTo eh
ReDim arr2(1 To List2.ListCount, 1 To 16)
For i = LBound(ListBoxContents) To UBound(ListBoxContents)
For j = LBound(pArr, 1) To UBound(pArr, 1)
If ListBoxContents(i) = pArr(i, 1) Then
arr2(k, m) = pArr(i, j)
k = k + 1
m = m + 1
End If
Next j
Next i
eh:
MsgBox Err.Description
End Sub
Change the middle part of the code to be -->
k = 0 ' need to initialize (and also add headings to row zero)
For i = LBound(ListBoxContents) To UBound(ListBoxContents)
For j = LBound(pArr, 1) To UBound(pArr, 1)
If ListBoxContents(i) = pArr(J, 1) Then ' pArr needs to be J
k = k + 1 ' got a match, ergo increment the output row
For m = 0 To UBound(pArr, 2) - 1
arr2(k, m) = pArr(J, m) ' move into col m, from pArr J row
Next m
End If
Next j
Next i
Exit Sub ' do not drop thru
Also as Comintern sez --> pArr is never assigned a value.
Also, are you getting what you want from
Dim i, j, k, m, ListSize As Integer

Correlation of Two Arrays in VBA

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

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

Add column (as first) with 1 to exsiting Variant Array in VBA

I have a array which have 1 or more columns and now I want to add one more column (consists only of 1), but I don't know how do do that. The situation looks like that:
My code:
Dim X() As Variant
X = Range("A1:C3").Value2
It's is important to put column with 1 as first. Probably I need to use ReDim Preserve but nothing works for me.
I think you have some options, but instead of extending the index of the array and transposing, trying to move the values etc which seems too much of a hassle, I would rather add 1 to the Excel range and then create the array:
Range("B1:D3").Value2 = Range("A1:C3").Value2
Range("A1:A3").Value2 = 1
X = Range("A1:D3").Value2
Resize the Array adding a column to the last dimension
Shift all the data to the right.
Assign 1 to the first position in each row
Sub AddColumnShiftData()
Dim X As Variant
Dim i As Long, j As Long
X = Range("A1:C3").Value2
ReDim Preserve X(1 To 3, 1 To 4)
For i = 1 To UBound(X)
For j = UBound(X, 2) To 2 Step -1
X(i, j) = X(i, j - 1)
Next
X(i, 1) = 1
Next
End Sub
Try matrix multiplication by the identify matrix....Well almost identity matrix. Then add 1 to every element in of the resulting matrix. You can use the Excel's Worksheet function for matrix multiplication.
Almost identity matrix
Dim X As Variant
X = Range("A1:C3").Value2
Dim Y As Variant
n = UBound(X, 2)
m = n + 1
Z = UBound(X, 1)
ReDim Y(1 To n, 1 To m)
'Set All values to zero
For i = 1 To n
For j = 1 To m
Y(i, j) = 0
Next j
Next i
' Set offset diagonal to 1
For i = 1 To n
Y(i, i + 1) = 1
Next i
' Matrix MMult
X = Application.WorksheetFunction.MMult(X, Y)
' Add 1 to the first column
For i = 1 To Z
X(i, 1) = 1
Next i
Alternative via Application.Index()
Just for fun (note that the resulting array is a 1-based 2-dim array):
Sub AddFirstIndexColumn()
Const FIXEDVALUE = 1 ' value to replace in new column 1
'[1] get data
Dim v: v = getExampleData()
'[2] define column array inserting first column (0 or 1) and preserving old values (1,2,3)
v = Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v) & ")"), _
Array(1, 1, 2, 3)) ' columns array where 0 reinserts the first column
' [3] add an current number in the first column
Dim i As Long
For i = LBound(v) To UBound(v): v(i, 1) = FIXEDVALUE: Next i
End Sub
Function getExampleData()
' Method: just for fun a rather unusual way to create a 2-dim array
' Caveat: time-consuming for greater data sets; better to assign a range to a datafield array
Dim v
v = Array(Array(2, 3, 5), Array(3, 8, 9), Array(4, 2, 1))
v = Application.Index(v, 0, 0)
getExampleData = v
End Function
Related links
Some pecularities of `Application.Index()
Insert vertical slices into array

Copy 1D array to multidimensional array - VBA

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

Resources