I am trying to devise a code that enables me to repeat a range (of one column) to be repeated Nth times. This is my try (and it is working) but I need your ideas to improve the code if possible
Sub Test()
Const N As Integer = 3
Dim a, i As Long, ii As Long, k As Long
a = ActiveSheet.Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row).Value
ReDim b(1 To UBound(a, 1) * N, 1 To 1)
For i = 1 To N
For ii = LBound(a, 1) To UBound(a, 1)
k = k + 1
b(k, 1) = a(ii, 1)
Next ii
Next i
Range("C1").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I would do it similarly...
Sub Test()
Dim a, c&, i&, k&
Const n& = 3
a = [a1].Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
[c1].Resize(UBound(b)) = b
End Sub
But it would be best to make it into an encapsulated procedure...
Sub Test()
CloneRange [a1], [c1], 3
End Sub
Sub CloneRange(rSrc As Range, rDst As Range, Optional n& = 1)
Dim a, c&, i&, k&
a = rSrc.Resize(Cells(Rows.Count, 1).End(xlUp).Row)
ReDim b(1 To n * UBound(a), 1 To 1)
For k = 1 To n
For i = 1 To UBound(a)
c = c + 1
b(c, 1) = a(i, 1)
Next
Next
rDst.Resize(UBound(b)) = b
End Sub
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
Column A in sheet1 has the values [1,2,3,4,5,6] in range("A1:A6") and what I am trying to do is to get all the combinations of summing each two numbers and each three numbers and each four numbers and each five numbers
This is what I did till now but the results are not as I expected
Sub Test()
Dim a, b, lr As Long, i As Long, j As Long, k As Long, ii As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
For j = i To lr
For ii = j To lr
Cells(i, ii + 1) = i & "+" & j & "+" & ii & "=" & i + j + ii
Next ii
Next j
Next i
With Range("A1").CurrentRegion
a = .Offset(, 1).Resize(, .Columns.Count - 1).Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
For i = LBound(a) To UBound(a)
For j = LBound(a, 2) To UBound(a, 2)
If a(i, j) <> "" Then
k = k + 1
b(k, 1) = a(i, j)
End If
Next j
Next i
.Cells(1, .Columns.Count + 2).Resize(k).Value = b
End With
End Sub
Example of the desired output:
Each two numbers together >>
Sub Test()
Dim a, b, lr As Long, i As Long, j As Long, k As Long, ii As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
For j = i To lr
Cells(i, j + 1) = i & "+" & j & "=" & i + j
Next j
Next i
With Range("A1").CurrentRegion
a = .Offset(, 1).Resize(, .Columns.Count - 1).Value
ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
For i = LBound(a) To UBound(a)
For j = LBound(a, 2) To UBound(a, 2)
If a(i, j) <> "" Then
k = k + 1
b(k, 1) = a(i, j)
End If
Next j
Next i
.Cells(1, .Columns.Count + 2).Resize(k).Value = b
End With
End Sub
The results would be like that in column J
1+1=2
1+2=3
1+3=4
1+4=5
1+5=6
1+6=7
2+2=4
2+3=5
2+4=6
2+5=7
2+6=8
3+3=6
3+4=7
3+5=8
3+6=9
4+4=8
4+5=9
4+6=10
5+5=10
5+6=11
6+6=12
This is OK for each two numbers .. How can I get the results for each three numbers and for each four numbers and for each five numbers?
** #Vityata
Public Sub PrintArrayOnSingleLine(myArray As Variant)
Dim i As Long, x As Long
Dim textArray As String, temp As String
For i = LBound(myArray) To UBound(myArray)
textArray = textArray & myArray(i)
x = x + Val(myArray(i))
temp = temp & "+" & myArray(i)
Next i
Dim myLastRow As Long
myLastRow = LastRow(Worksheets(1).Name) + 1
ActiveSheet.Cells(myLastRow, 1) = Mid(temp, 2) & "=" & x
End Sub
I have edited the procedure as you told me, but just one note, I can't get the same number to be summed. Example: 1+1=2
Combination (not repeating same values):
Copy the code below and run it. Then change the variable in size = n. The given numbers are in the initialArray. In the end, instead of printing the array as a textArray, add a variable to sum it:
Sub Main()
Dim size As Long: size = 2
Dim initialArray As Variant: initialArray = Array(1, 2, 3, 4, 5, 6)
Dim arr As Variant: ReDim arr(size - 1)
Dim n As Long: n = UBound(arr) + 1
EmbeddedLoops 0, size, initialArray, n, arr
End Sub
Function EmbeddedLoops(index As Long, size As Long, initialArray As Variant, n As Long, arr As Variant)
Dim p As Variant
If index >= size Then
If Not AnyValueBiggerThanNext(arr) And Not AnyValueIsRepeated(arr) Then
PrintArrayOnSingleLine arr
End If
Else
For Each p In initialArray
arr(index) = p
EmbeddedLoops index + 1, size, initialArray, n, arr
Next p
End If
End Function
Public Function AnyValueBiggerThanNext(arr As Variant) As Boolean
Dim i As Long
For i = LBound(arr) To UBound(arr) - 1
If arr(i) > arr(i + 1) Then
AnyValueBiggerThanNext = True
Exit Function
End If
Next i
AnyValueBiggerThanNext = False
End Function
Public Function AnyValueIsRepeated(arr As Variant) As Boolean
On Error GoTo AnyValueIsRepeated_Error:
Dim element As Variant
Dim testCollection As New Collection
For Each element In arr
testCollection.Add "item", CStr(element)
Next element
AnyValueIsRepeated = False
On Error GoTo 0
Exit Function
AnyValueIsRepeated_Error:
AnyValueIsRepeated = True
End Function
Public Sub PrintArrayOnSingleLine(myArray As Variant)
Dim i As Long
Dim textArray As String
For i = LBound(myArray) To UBound(myArray)
textArray = textArray & myArray(i)
Next i
Debug.Print textArray
End Sub
Permutation (repeating same values)
Sub Main()
Static size As Long
Static c As Variant
Static arr As Variant
Static n As Long
size = 3
c = Array(1, 2, 3, 4, 5, 6)
n = UBound(c) + 1
ReDim arr(size - 1)
EmbeddedLoops 0, size, c, n, arr
End Sub
Function EmbeddedLoops(index, k, c, n, arr)
Dim i As Variant
If index >= k Then
PrintArrayOnSingleLine arr
Else
For Each i In c
arr(index) = i
EmbeddedLoops index + 1, k, c, n, arr
Next i
End If
End Function
Public Sub PrintArrayOnSingleLine(myArray As Variant)
Dim counter As Integer
Dim textArray As String
For counter = LBound(myArray) To UBound(myArray)
textArray = textArray & myArray(counter)
Next counter
Debug.Print textArray
End Sub
Sources (Disclaimer - from my blog):
VBA Nested Loop with Recursion
VBA All Combinations
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 have a current code that is supposed to compare tables in sheet1 to sheet2 and output the matches in another sheet(sheet3). When trying to run the code, I am getting "Type mismatch" error" and I'm not sure what is wrong nor how to fix it...
Picture of VBA code and the second table/sheet:
Sub CompareSolve()
Dim i As Long
Dim j As Long
Dim n As Long
Dim ar As Variant
ar = Sheet2.Cells(10, 1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(ar, 1)
.Item(ar(i, 1)) = Empty
Next
ar = Sheet1.Cells(10, 1).CurrentRegion.Value
n = 1
For i = 2 To UBound(ar, 1)
If .exists(ar(i, 1)) Then
n = n + 1
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next j
End If
Next i
End With
Sheet3.Cells(10, 8).Resize(n, UBound(ar, 2)).Value = ar
End Sub
These two tables are in the same position on the sheets for these 2 sheets
Fixed code thanks to help from #Tom
Dim i As Long
Dim j As Long
Dim n As Long
Dim ar As Variant
ar = Sheet2.Cells(10, 1).CurrentRegion.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(ar, 1)
.Item(ar(i, 1)) = Empty
Next
ar = Sheet1.Cells(10, 1).CurrentRegion.Value
n = 1
For i = 2 To UBound(ar, 1)
If .exists(ar(i, 1)) Then
n = n + 1
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next j
End If
Next i
End With
Sheet3.Cells(10, 8).Resize(n, UBound(ar, 2)).Value = ar
End Sub```
I have two procedures that both run out of memory due to my data set in Excel exceeding a very vast amount.
Sub format()
Dim x, Y(), i&, j&, k&, s
x = Range("A1", Cells(1, Columns.count).End(xlToLeft)).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(x, 2)
.Item(x(1, i)) = i
Next i
x = Application.Trim(Range("BL3", Cells(Rows.count, "BL").End(xlUp)).Value)
ReDim Y(1 To UBound(x), 1 To .count): j = 1
For i = 1 To UBound(x)
If InStr(x(i, 1), "==") = 0 Then
s = Split(x(i, 1))
If .Exists(s(0)) Then
k = .Item(s(0)): Y(j, k) = mid(x(i, 1), Len(s(0)) + 2)
End If
Else
j = j + 1
End If
Next i
End With
[a2].Resize(j, UBound(Y, 2)).Value = Y()
End Sub
Above is the procedure I've been using to split/trim a column of data into several rows/columns.
Ive put data into two columns, each consisting of 60k rows each, what I need to do is once its read through BL, read through BO and continue where it left off putting the second row of data underneath the new row from whereever the first one finished
Something like this (UNTESTED) might work for you. It avoids creating a huge 2D array by using smaller-size blocks.
Sub format()
Const BLOCK_SIZE As Long = 10000
Dim x, Y(), i&, j&, k&, s
Dim d As Object
Dim rOffset As Long
Dim xCount As Long
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = 1
x = Range("A1", Cells(1, Columns.Count).End(xlToLeft)).Value
For i = 1 To UBound(x, 2)
'using Add: you probably want this to error if duplicates exist...
d.Add x(1, i), i
Next i
x = Application.Trim(Range("BL3", Cells(Rows.Count, "BL").End(xlUp)).Value)
xCount = UBound(x)
rOffset = 0
ReDim Y(1 To BLOCK_SIZE, 1 To d.Count)
j = 1
For i = 1 To xCount
If InStr(x(i, 1), "==") = 0 Then
s = Split(x(i, 1))
If d.Exists(s(0)) Then
k = d(s(0))
Y(j, k) = Mid(x(i, 1), Len(s(0)) + 2)
End If
Else
j = j + 1
If j > BLOCK_SIZE Then
[a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y()
ReDim Y(1 To BLOCK_SIZE, 1 To d.Count)
j = 1
rOffset = rOffset + BLOCK_SIZE
End If
End If
Next i
[a2].Offset(rOffset, 0).Resize(BLOCK_SIZE, d.Count).Value = Y()
End Sub