I am trying to slice the first dimension of 2D array. The array variable is y (1 to 36, 1 to 19)
I need to make it y(1 to 12, 1 to 19)
To do such task I have to loop like that
If rw > 0 Then
ListBox1.AddItem
ReDim v(1 To n, 1 To UBound(y, 2))
Dim i As Long, j As Long
For i = 1 To n
For j = 1 To UBound(y, 2)
v(i, j) = y(i, j)
Next j
Next i
ListBox1.List = v()
n = 0
End If
Is there an easier way to do such task without too much loops?
You can slice an array as below. Most of this code is just to populate the first array so you won't need:
Sub x()
Dim v1(1 To 6, 1 To 3), i As Long, j As Long, v2()
'this loop is just to populate the first array
For i = 1 To UBound(v1, 1)
For j = 1 To UBound(v1, 2)
v1(i, j) = i * j
Next j
Next i
'this is just to show the contents
Range("A1").Resize(UBound(v1, 1), UBound(v1, 2)) = v1
'this does the slicing (first three rows
v2 = Application.Index(v1, Evaluate("row(1:3)"), Application.Transpose(Evaluate("row(1:" & UBound(v1, 2) & ")")))
'this shows the sliced array
Range("F1").Resize(UBound(v2, 1), UBound(v2, 2)) = v2
End Sub
you could use Tranpose():
Dim v As Variant, v1 As Variant
v = Range("A1").Resize(36, 19).Value' just to fill a 36x19 array
v1 = Application.Transpose(v)
ReDim Preserve v1(1 To UBound(v, 2), 1 To 12)
v = Application.Transpose(v1)
Related
I have a 3 by 3 matrix, where elements (1,1), (2,1), (2,2), (3,1), (3,2), (3,3) are given:
X . .
X X .
X X X
I need to write a program that writes out the missing elements, where (1,2)=(2,1), (1,3)=(3,1) and (2,3)=(3,2). I have written the following code:
Function kiegeszito(a)
For i = 1 To 3
For j = 1 To 3
If i < j Then
a(i, j) = a(j, i)
Else
a(i, j) = a(i, j)
End If
Next j
Next i
kiegeszito = a
End Function
However, this does not seem to work, could anybody help me why is this not working?
Just remove the Else condition:
Function kiegeszito(a)
For i = 1 To 3
For j = 1 To 3
If i < j Then a(i, j) = a(j, i)
Next j
Next i
kiegeszito = a
End Function
Get twin data in 2-dim matrix avoiding extra n*(n-1)/2 condition checks
The following approach
reduces the number of unnecessary condition checks by incrementing the 2nd loop starts
accepts any wanted base of 2-dim data:
Sub CompleteMatrix(ByRef data)
'count row|=column elements
Dim cnt As Long: cnt = UBound(data) - LBound(data) + 1
'fill missing twin data (identified by inverted indices)
Dim i As Long, j As Long
For i = LBound(data) To cnt - 1
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'next column starts from incremented row index
'(thus avoiding n*(n-1)/2 IF-conditions)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For j = i + 1 To UBound(data, 2)
data(i, j) = data(j, i) ' assign twin data
Next j
Next i
End Sub
An example call creating e.g. a 1-based 2-dim datafield array might be
Sub ExampleCall()
Dim v: v = Tabelle3.Range("A1:C3").Value
CompleteMatrix v
End Sub
Further link
A practical example using such a mirrored array might be a distance array; a related post demonstrates how to apply the FilterXML() function thereon.
Fill Array
Using a method (fillArray) you could modify the array 'in place':
The Code
Option Explicit
Sub fillArrayTEST()
Dim Data As Variant: Data = Range("A1:C3").Value
debugPrint2D Data
fillArray Data
debugPrint2D Data
End Sub
Sub fillArray(ByRef Data As Variant)
Dim cCount As Long: cCount = UBound(Data, 2)
Dim i As Long, j As Long
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
If i < j Then Data(i, j) = Data(j, i)
Next j
Next i
End Sub
Sub debugPrint2D(ByVal Data As Variant)
Dim i As Long, j As Long
For i = LBound(Data, 1) To UBound(Data, 1)
For j = LBound(Data, 2) To UBound(Data, 2)
Debug.Print "[" & i & "," & j & "]", Data(i, j)
Next j
Next i
End Sub
A Homage to T.M.'s Brilliant Solution
Sub completeMatrix(ByRef Data As Variant)
Dim rLower As Long: rLower = LBound(Data, 1)
Dim cLower As Long: cLower = LBound(Data, 2)
Dim iDiff As Long: iDiff = cLower - rLower
Dim cStart As Long: cStart = iDiff + 1
Dim cUpper As Long: cUpper = UBound(Data, 2)
Dim r As Long, c As Long
For r = rLower To UBound(Data, 1) - rLower
For c = cStart + r To cUpper
Data(r, c) = Data(c - iDiff, r + iDiff)
Next c
Next r
End Sub
Sub completeMatrixTEST()
Dim Data As Variant: ReDim Data(0 To 2, 2 To 4)
Data(0, 2) = 1
Data(1, 2) = 2
Data(1, 3) = 3
Data(2, 2) = 4
Data(2, 3) = 5
Data(2, 4) = 6
debugPrint2D Data
completeMatrix Data
'Range("G1").Resize(UBound(Data, 1) - LBound(Data, 1) + 1, _
UBound(Data, 2) - LBound(Data, 2) + 1).Value = Data
Debug.Print
debugPrint2D Data
End Sub
I'm new to VBA and was surprised that there isn't a function to insert elements in an array (my previous question). So I rethought my approach a bit.
On screen I have the following example table 'allActualWeights'. There are a lot of blanks (no weight value) that I want to get rid of (the table is different everytime). So the end result should be 'actualWeights'.
In my code I tried the following:
Option Base 1
Dim allActualWeights
allActualWeights = Range("A6:E29").Value
Dim actualWeights
actualWeights = allActualWeights
For Index = 1 To 24
If allActualWeights(Index, 2) <> 0 Then
ReDim actualWeights(Index, 5)
actualWeights(Index, 1) = allActualWeights(Index, 1)
actualWeights(Index, 2) = allActualWeights(Index, 2)
actualWeights(Index, 3) = allActualWeights(Index, 3)
actualWeights(Index, 4) = allActualWeights(Index, 4)
actualWeights(Index, 5) = allActualWeights(Index, 5)
End If
Next Index
Range("G6:K29") = actualWeights
But I'm not getting the results I hoped for.
What am I doing wrong, or is there a better approach?
Here's one approach:
Sub Tester()
Dim allActualWeights, actualweights(), i As Long, n As Long, c As Long
Dim rngSource As Range
Set rngSource = ActiveSheet.Range("A6:E29")
With rngSource
allActualWeights = .Value
'size the output array # of rows to count of values in ColB
ReDim actualweights(1 To Application.CountA(.Columns(1)), _
1 To .Columns.Count)
End With
n = 1
For i = LBound(allActualWeights, 1) To UBound(allActualWeights, 1)
If Len(allActualWeights(i, 2)) > 0 Then
For c = LBound(allActualWeights, 2) To UBound(allActualWeights, 2)
actualweights(n, c) = allActualWeights(i, c)
Next c
n = n + 1 'next output row
End If
Next i
'put the array on the sheet
Range("G6").Resize(UBound(actualweights, 1), UBound(actualweights, 2)) = actualweights
End Sub
This should do it and is easily maintainable...
Sub ActualWeights()
Dim c&, i&, j&, n&, a, b
With [a6:e29] '<-- allActualWeights
a = .Value2
n = UBound(a) - Application.CountBlank(.Offset(, 1).Resize(, 1))
ReDim b(1 To n, 1 To UBound(a, 2))
For i = 1 To UBound(a)
If a(i, 2) Then
c = c + 1
For j = 1 To UBound(a, 2)
b(c, j) = a(i, j)
Next
End If
Next
.Offset(, 6).Resize(n) = b
End With
End Sub
I am trying to use the Application.Index function with an variant 2D Array which contains some elements having >255 characters of text. This results in Variant/Integer Type Type Mismatch error. I am also unable to use Application.Transpose because of hitting this >255 characters limit.
Has anyone made any Custom INDEX UDFunction that can handle >255 characters of text to overcome this limit?
e.g.
The snippet code looks like this:
........
........
For j = 1 to NoOfSlides
A = (j - 1) * (nRw * 2) + 1
B = IIf(A >= UBound(Arr, 1), UBound(Arr, 1), (A + (nRw * 2)) - 1)
If B > UBound(Arr, 1) Then B = UBound(Arr, 1)
ab_Rng = Evaluate("row(" & A & ":" & B & ")")
TmpArr(j) = Application.Index(Arr, ab_Rng, Array(1, 2)) ' Type Mismatch Error
With oPres
Set oSlide = .slides("Slide0_ABC").Duplicate
oSlide.moveto toPos:=.slides.Count
With oSlide
....
End With
If getDimensions(TmpArr(j))<2 Then
TmpArr(j) = Application.Transpose(TransposeDim(TmpArr(j)) ) ' Error
End If
For y = LBound(TmpArr(j), 1) To UBound(TmpArr(j), 1)
.....
Next y
End With
Next j
........
........
Function getDimensions(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimensions = i - 1
On Error GoTo 0
Err.Clear
End Function
Function TransposeDim(v As Variant) As Variant
' Convert 1D Array to 2D Array (1 -Based)
Dim x As Long, y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
on error resume next
Xupper = UBound(v, 2)
if err.number <>0 then
Redim Preserve v(1 to ubound(v), 1 to 1)
Xupper = UBound(v, 2)
endif
on error goto 0
Yupper = UBound(v, 1)
ReDim tempArray(1 To Xupper, 1 To Yupper)
For x = 1 To Xupper
For y = 1 To Yupper
tempArray(x, y) = v(y, x)
Next y
Next x
TransposeDim = tempArray
End Function
Edit:
Here is a Sample.xlsm file and a Sample PPT Template for anyone's perusal.
Dim a(1 To 2, 1 To 2) As String
Dim o As String
a(1, 2) = "testing " & String(255, "x")
o = Application.Index(a, 1, 2)
Debug.Print Len(o)
To support my comment, you are not using index correctly. I think you'll need to use your Array(1, 2)(0) and Array(1, 2)(1)
Interestingly, though strange enough, i found that as the Arr is defined as a Variant and pulls in Range data .e.g.
Arr = Sheet1.Range("A3:B8").Formula ' a Variant/Variant array
INDEX, TRANSPOSE, MATCH etc., will not work and result in Type MisMatch Error on hitting the >255 Characters limit. I think it internally uses an Integer index and therefore maintains a 255 character limit.
However, if i defined the Array Arr as a String:
' Define Arr as a String
ReDim Arr(1 To UBound(VarRng.Formula, 1), 1 To UBound(VarRng.Formula, 2)) As String
For x = LBound(VarRng.Formula, 1) To UBound(VarRng.Formula, 1)
For y = LBound(VarRng.Formula, 2) To UBound(VarRng.Formula, 2)
Arr(x, y) = CStr(VarRng.Formula(x, y))
Next y
Next x
'...then INDEX, TRANSPOSE, MATCH etc., will work properly, even though there are >255 Characters in the Array.
' Define Arr as a String
ReDim Arr(1 To UBound(VarRng.Formula, 1), 1 To UBound(VarRng.Formula, 2)) As String
For x = LBound(VarRng.Formula, 1) To UBound(VarRng.Formula, 1)
For y = LBound(VarRng.Formula, 2) To UBound(VarRng.Formula, 2)
Arr(x, y) = CStr(VarRng.Formula(x, y))
Next y
Next x
`Arr` is now a Variant/String
'....
'....
For j = 1 to NoOfSlides
A = (j - 1) * (nRw * 2) + 1
B = IIf(A >= UBound(Arr, 1), UBound(Arr, 1), (A + (nRw * 2)) - 1)
If B > UBound(Arr, 1) Then B = UBound(Arr, 1)
ab_Rng = Evaluate("row(" & A & ":" & B & ")")
TmpArr(j) = Application.Index(Arr, ab_Rng, Array(1, 2))
'....
Next j
Sample.xlsm and PPT Sample Template.pptx
Hope this helps.
I'm trying to use an INDEX(MATCH,MATCH) to recreate this formula:
INDEX(Inflation!H$129:H$188,MATCH($J10,Inflation!$C$129:$C$188,0))
You may notice that the columns are not locked on the INDEX array field Inflation!H$129:H$188. I didn't know how to move over one column so I thought I would use an INDEX(MATCH,MATCH).
With my code below I get a error 13 Type Mismatch even if I swap out arrInflation_Bucket(I, 1) for "EWIP", a known entry in the searched range.
Sub Costs__Repossession_Costs()
Dim I, J, arrInflation_Bucket, arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Label_Match, arrInflation_Quarter_Match
arrNumber_of_Assets = Range("Costs.Number_of_Assets")
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket")
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label")
ReDim arrCosts__Repossession_Costs(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2))
For I = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
For J = LBound(arrQuarters, 2) To UBound(arrQuarters, 2)
arrInflation_Label_Match(I, J) = Application.Match(arrInflation_Bucket(I, 1), Range("Inflation.Inflation_Bucket_Label"), 0)
arrInflation_Quarter_Match(I, J) = Application.WorksheetFunction.Match(arrQuarters(1, J), Range("Quarters_1to40"), 0)
arrCosts__Repossession_Costs(I, J) = Application.WorksheetFunction.Index(Range("Inflation.Cumulative"), arrInflation_Label_Match, arrInflation_Quarter_Match)
Next J
Next I
End Sub
This is by far the most complicated formula I will need to do in VBA so if I can get this it should be all smooth sailing.
OK, I've updated the code with he instructions of the first two comments, very helpful. It is now performing the two matches correctly (used to error out on the first, but now gives me row 48 adn column 1 which is correct) but Now Type 13 errors on the INDEX().
Sub Costs__Repossession_Costs()
Dim I As Long
Dim J As Long
Dim arrInflation_Bucket As Variant
Dim arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Label_Match, arrInflation_Quarter_Match, arrInflation_Cumulative
arrNumber_of_Assets = Range("Costs.Number_of_Assets")
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket")
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label")
arrInflation_Cumulative = Range("Inflation.Cumulative")
ReDim arrCosts__Repossession_Costs(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2)), _
arrInflation_Label_Match(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2)), _
arrInflation_Quarter_Match(1 To UBound(arrNumber_of_Assets, 1), 1 To UBound(arrQuarters, 2))
For I = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
For J = LBound(arrQuarters, 2) To UBound(arrQuarters, 2)
arrInflation_Label_Match(I, J) = Application.Match(arrInflation_Bucket(I, 1), Range("Inflation.Inflation_Bucket_Label"), 0)
arrInflation_Quarter_Match(I, J) = Application.WorksheetFunction.Match(arrQuarters(1, J), Range("Quarters_1to40"), 0)
arrCosts__Repossession_Costs(I, J) = Application.WorksheetFunction.Index(arrInflation_Cumulative, arrInflation_Label_Match, arrInflation_Quarter_Match)
Next J
Next I
End Sub
OK, so I caved like a you know what and asked my genius friend for help with this. His fantastic code is below:
Function firstMatchInRow(ByVal val, arr, ByVal col As Long) As Long
Dim i As Long
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, col) = val Then firstMatchInRow = i: Exit Function
Next i
End Function
Sub Costs__Repossession_Costs()
Dim i As Long, j As Long, tempLabelMatch As Long
Dim arrInflation_Bucket, arrInflation_Bucket_Label, arrNumber_of_Assets, arrQuarters, arrInflation_Cumulative, arrCosts__Repossession_Costs
arrQuarters = Range("Quarters_1to40")
arrInflation_Bucket = Range("Costs.Inflation_Bucket").Value
arrInflation_Bucket_Label = Range("Inflation.Inflation_Bucket_Label").Value
arrInflation_Cumulative = Range("Inflation.Cumulative").Value ' + add values
ReDim arrCosts__Repossession_Costs(1 To UBound(arrInflation_Cumulative, 1), 1 To UBound(arrQuarters, 2))
For i = LBound(arrInflation_Bucket, 1) To UBound(arrInflation_Bucket, 1)
tempLabelMatch = firstMatchInRow(arrInflation_Bucket(i, 1), arrInflation_Bucket_Label, 1)
For j = LBound(arrInflation_Cumulative, 2) To UBound(arrInflation_Cumulative, 2)
arrCosts__Repossession_Costs(i, j) = arrInflation_Cumulative(tempLabelMatch, j)
Next j
Next i
End Sub
I need to join two arrays vd and vd1 into vdu.
ReDim vdu(1 To (UBound(vd, 1) + UBound(vd1, 1)), 1 To 1)
For i = 1 To UBound(vd, 1)
vdu(i, 1) = vd(i, 1)
Next i
For j = i To UBound(vdu, 1)
vdu(j, 1) = vd1(j - i + 1, 1)
Next j
First, I get and "out of range" error.
Second, in the end I will have 18 arrays that I'll need to join, so I don't know if this is the best idea for joining them.
try with
ReDim vdu(LBound(vd) To UBound(vd) + UBound(vd1), 1 To 1)
For i = LBound(vdu) To UBound(vdu)
If i <= UBound(vd) Then
vdu(i, 1) = vd(i, 1)
Else
vdu(i, 1) = vd1(i - UBound(vd), 1)
End If
Next i
Update for second part of question
I'd convert your merge code into a function
Public Function MergeArrays(arr1 As Variant, arr2 As Variant) As Variant
Dim i As Long
Dim arr As Variant
ReDim arr(LBound(arr1, 1) To UBound(arr1, 1) + UBound(arr2, 1), 1 To 1)
For i = LBound(arr, 1) To UBound(arr, 1)
If i <= UBound(arr1, 1) Then
arr(i, 1) = arr1(i, 1)
Else
arr(i, 1) = arr2(i - UBound(arr1, 1), 1)
End If
Next i
MergeArrays = arr
End Function
And then pass each array to it 1 at a time e.g.
arr = MergeArrays(vd1, vd2)
arr = MergeArrays(arr, vd3)
arr = MergeArrays(arr, vdx)
You could loop through this by storing your arrays in an array or dictionary and looping through that instead as well
Other option
Public Function MergeArrays(ParamArray arrays() As Variant) As Variant
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
This method uses a ParamArray. If you're not sure what that is look it up but effectively you're able to pass an unspecified amount of arguments to the function. Therefore with this function you can combine any amount of arrays (of the same shape and same base i.e. x to x, 1 to 1) and it will combine them. Call like
arr = MergeArrays(vd, vd1, vd2,....,vd18)
getMasterArray will return an array that combines up to 60 different 2d arrays into one. getMasterArray also give you the option of returning a 0 or based array.
Sub TestgetMasterArray()
Dim data
data = getMasterArray(False, Range("List1").Value, Range("List2").Value, Range("List3").Value, Range("List4").Value)
Worksheets("Result").Range("A1").Resize(UBound(data), UBound(data, 2)).Value = data
End Sub
Function getMasterArray(Base0 As Boolean, ParamArray Arrays() As Variant)
Dim result As Variant, v As Variant
Dim Count As Long, Count2 As Long, lowBound As Integer, lOffset As Integer, x As Long, x1 As Long, y As Long
For Each v In Arrays
Count = Count + UBound(v) + IIf(LBound(v) = 0, 1, 0)
y = UBound(v, 2) + IIf(LBound(v, 2) = 0, 1, 0)
If y > Count2 Then Count2 = y
Next
lowBound = IIf(Base0, 0, 1)
ReDim result(lowBound To Count, lowBound To Count2)
For Each v In Arrays
If LBound(v, 2) > LBound(result, 2) Then
lOffset = -1
ElseIf LBound(v, 2) < LBound(result, 2) Then
lOffset = 1
End If
For x = LBound(v) To UBound(v)
For y = LBound(v, 2) To UBound(v, 2)
result(lowBound, y + lOffset) = v(x, y)
Next
lowBound = lowBound + 1
Next
Next
getMasterArray = result
End Function
Sample data generated by ockaroo.com