Say I have two columns Aand B in my spreadsheet:
A B
0.2 1
0.0 1
0.5 2
0.7 3
1.5 3
2.7 3
0.1 4
How do I convert this to a jagged array based on the value of B such that
arr = [[0.2, 0.0],
[0.5],
[0.7, 1.5, 2.7],
[0.1]]
This is what I did:
Dim uniqueT() As Variant: uniqueT = DistinctValues(Application.Transpose(Range("arrT")))
Dim nMaturities As Integer: nMaturities = UBound(uniqueT)
Dim nKnots As Integer, row As Integer
Dim K() As Variant: ReDim K(1 To nMaturities)
Dim mids() As Variant: ReDim mids(1 To nMaturities)
With Application.WorksheetFunction
For i = 1 To nMaturities
nKnots = .CountIf(Range("arrT"), "=" & uniqueT(i))
row = .Match(uniqueT(i), Range("arrT"), False) - 1
K(i) = .Transpose(Range("arrK").Cells(1).Offset(row, 0).Resize(nKnots, 1))
mids(i) = .Transpose(Range("arrMid").Cells(1).Offset(row, 0).Resize(nKnots, 1))
Next i
End With
I don't think you'll get a jagged array but the below will give you space fot the maximum number and blanks if there is no values.
Sub jag_array()
Dim maxcolb As Long, countcolb As Long, arr() As Variant
maxcolb = Application.Max(Columns(2))
countcolb = 1
ReDim arr(1 To maxcolb, 1 To countcolb) As Variant
'cycle through all values eg 1 to 4
For i = 1 To maxcolb
'expand the array as required
If Application.CountIf(Columns(2), i) > countcolb Then
countcolb = Application.CountIf(Columns(2), i)
ReDim Preserve arr(1 To UBound(arr, 1), 1 To countcolb) As Variant
End If
'find and cycle through all found column b
Set c = Columns(2).Find(i, After:=Cells(1, 2), LookIn:=xlValues)
If Not c Is Nothing Then
j = 1
firstAddress = c.Address
Do
'add column a value
arr(i, j) = Cells(c.Row, 1).Value
j = j + 1
Set c = Columns(2).FindNext(c)
If c Is Nothing Then Exit Do
Loop While c.Address <> firstAddress
End If
Next
'use arr(x, y) as you need to
End Sub
Related
I want to sort below Two-digit array by VBA code
A 1
B 2
A 1
C 3
or below:
1 A
2 B
1 A
3 C
I have tried to sort them by Dictionary, but, Dictionary is not allowed to insert duplate key.
Is there any want to sort above array by number 1,2,3
I made this some time ago, it might help.
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
Dim Menor As String
Dim NewArray() As Variant
Dim i As Double, j As Double
Dim menorIndex As Double
Dim NewArrayIndex() As Double
Dim UsedIndex() As Double
ReDim NewArrayIndex(UBound(RecArray, 2))
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
For i = 0 To UBound(NewArrayIndex)
NewArrayIndex(i) = -1
Next i
UsedIndex = NewArrayIndex
For i = 0 To UBound(RecArray, 2)
Menor = ""
menorIndex = -1
For j = 0 To UBound(RecArray, 2)
If UsedIndex(j) = -1 Then
If Menor = "" Then
Menor = RecArray(RefCol, j)
menorIndex = j
Else
If RecArray(RefCol, j) < Menor Then
Menor = RecArray(RefCol, j)
menorIndex = j
End If
End If
End If
Next j
UsedIndex(menorIndex) = 1
NewArrayIndex(i) = menorIndex
Next i
For i = 0 To UBound(NewArrayIndex)
For j = 0 To UBound(NewArray)
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
Next j
Next i
ArraySorter = NewArray
End Function
If you have something like:
Function testArraySorter()
Dim myArr() As Variant
ReDim myArr(1, 3)
myArr(0, 0) = "A"
myArr(0, 1) = "B"
myArr(0, 2) = "A"
myArr(0, 3) = "C"
myArr(1, 0) = 1
myArr(1, 1) = 2
myArr(1, 2) = 1
myArr(1, 3) = 3
myArr = ArraySorter(myArr)
For i = 0 To UBound(myArr, 2)
Debug.Print myArr(0, i), myArr(1, i)
Next i
End Function
you'll get this in your immediate verification :
A 1
A 1
B 2
C 3
If you need to sort based in two or more columns, you could add a dummy column into your array, concatenate the criteria columns into it and then set this dummy column as RefCol: myArr = ArraySorter(myArr, addedColNumberHere).
Hope this helps.
Suppose I have a column of values
1
2
3
4
5
I'm trying to write a VBA function where based on what number I chose(n)
the cells will loop around to that position. So say I i chose 3
Then new list will be
4
5
1
2
3
What I have done is based on each row number, I have tried to develop rules to move the cells but it doesn't seem to be working.. I suspect it's cause I'm using activerow and not the relative row position, but I'm not sure what the syntax is for relative row. Can someone help me out
Option Explicit
Option Base 1
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Integer, j As Integer
Dim nr As Integer, nc As Integer
Dim B() As Variant
Dim r As ListRow
nr = rng.Rows.Count
nc = rng.Columns.Count
r = ActiveCell.Row
ReDim B(nr, nc) As Variant
For i = 1 To nr
For j = 1 To nc
If r = 1 And r < n Then
B(nr - (n - 1), j) = rng.Cells(i, j)
ElseIf r > 1 And r < n Then
B(nr - (n - r), j) = rng.Cells(i, j)
ElseIf r > n Then
B(r - n, j) = rng.Cells(i, j)
ElseIf r = n Then
B(r, j) = rng.Cells(i, j)
End If
Next j
Next i
DivisibleByN = B
End Function
Assuming you want to "roll" each column individually, you can do something like this:
Public Sub RollColumns(ByVal rng As Range, ByVal rollBy As Integer)
Dim rowsCount As Integer, colsCount As Integer
Dim rowsOffset As Integer, colsOffset As Integer
Dim r As Integer, c As Integer
rowsCount = rng.Rows.Count
colsCount = rng.Columns.Count
rowsOffset = rng.Rows(1).Row - 1
colsOffset = rng.Columns(1).Column - 1
If rowsCount = 1 Then Exit Sub
Dim arr As Variant
arr = rng.Value
For c = 1 To colsCount
For r = 1 To rowsCount
Dim targetIndex As Integer
targetIndex = (r + rollBy) Mod rowsCount
If targetIndex = 0 Then targetIndex = rowsCount
rng.Worksheet.Cells(r + rowsOffset, c + colsOffset).Value = _
arr(targetIndex, c)
Next r
Next c
End Sub
Usage:
RollColumns Range("A1:C5"), 3
See it in action:
you could use this
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Long, j As Long
With rng
ReDim B(0 To .Rows.Count - 1, 0 To .Columns.Count - 1) As Variant
For i = .Rows.Count To 1 Step -1
For j = 1 To .Columns.Count
B(i - 1, j - 1) = .Cells((.Rows.Count + i - (n + 1)) Mod .Rows.Count + 1, j)
Next
Next
DivisibleByN = B
End With
End Function
This was just to mess around with COM objects and explore them... could be tidied up. S&G moment.
Option Explicit
Public Sub test()
Const n As Long = 3 '<==Add your end point here
Dim arr(), i As Long, rng As Range
With ThisWorkbook.Worksheets("Sheet6") '<==Put your sheet name here
Set rng = .Range("A1:A5") '<== Add your single column range here
Dim maxValue As Variant
Dim minValue As Variant
maxValue = Application.Max(rng)
minValue = Application.Min(rng)
If IsError(maxValue) Or IsError(minValue) Then Exit Sub
If n > maxValue Or n < minValue Then Exit Sub
If rng.Columns.Count > 1 Then Exit Sub
If rng.Cells.Count = 1 Then
ReDim arr(1, 1): arr(1, 1) = rng.Value
Else
arr = rng.Value
End If
Dim list As Object, list2 As Object, queue As Object, arr2()
Set list = CreateObject("System.Collections.ArrayList")
Set queue = CreateObject("System.Collections.Queue")
For i = LBound(arr, 1) To UBound(arr, 1)
list.Add arr(i, 1)
Next
list.Sort
Set list2 = list.Clone
list2.Clear
arr2 = list.GetRange(n, maxValue - n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
queue.Clear
arr2 = list.GetRange(0, n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
rng.Cells(1, 1).Resize(list2.Count, 1) = Application.WorksheetFunction.Transpose(list2.toArray)
End With
End Sub
I've limited knowledge in maths so pardon the terms if i'm mistaken.
I need to create all possible combinations from multiple sets with at least 1 item included from that set.
- SetA: [1, 2, 3, 4, 5, 6, 7]
- SetB: [a, b, c, d]
- SetC: [!, #, #, $, %]
Example Output:
- [1,a,!]
- [1,2,a,c,#]
- [1,2,3,4,5,6,7,a,b,c,d,!,#,#,$,%]
Is there a specific combination formula for this since i can only come up with nested loops and i'm not sure if it is even correct.
#barrycarter had good idea of obtaining the power set. However, we don't need to reject anything as we are not getting the power set of the union of sets (this would end up being inefficient as there will be many rejects as the number of sets grows). We simply get the power set of each set, then get all combinations of those power sets. The subroutine below, works for an arbitrary number sets of arbitrary length.
Sub CreateAllCombs()
Dim ArrayOfPowSets() As Variant, mySet() As Variant, ArrCounter() As Long, myPS As Variant
Dim myCombs() As Variant, nextComb() As Variant, ParentComb() As Variant, ArrMax() As Long
Dim i As Long, j As Long, k As Long, count1 As Long, count2 As Long, CombExist As Boolean
Dim tempCol As Long, myMax As Long, maxRow As Long, totalCombs As Long
With ActiveSheet
maxRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
ReDim ArrayOfSets(1 To maxRow, 1 To 1)
ReDim ArrCounter(1 To maxRow)
ReDim ArrMax(1 To maxRow)
myMax = 0
For i = 1 To maxRow
With ActiveSheet
tempCol = .Cells(i, .Columns.count).End(xlToLeft).Column
End With
ReDim mySet(1 To tempCol)
For j = 1 To tempCol: mySet(j) = Cells(i, j): Next j
myPS = PowerSet(mySet)
ArrMax(i) = UBound(myPS)
If ArrMax(i) > myMax Then
myMax = ArrMax(i)
ReDim Preserve ArrayOfPowSets(1 To maxRow, 1 To ArrMax(i))
End If
For j = 1 To ArrMax(i)
ArrayOfPowSets(i, j) = myPS(j)
Next j
ArrCounter(i) = 1
Next i
CombExist = True
totalCombs = 0
Do While CombExist
count1 = 1
ReDim ParentComb(1 To 1)
For i = 1 To maxRow - 1
For j = 1 To UBound(ArrayOfPowSets(i, ArrCounter(i)))
ReDim Preserve ParentComb(1 To count1)
ParentComb(count1) = ArrayOfPowSets(i, ArrCounter(i))(j)
count1 = count1 + 1
Next j
Next i
For i = 1 To ArrMax(maxRow)
count2 = count1
nextComb = ParentComb
For j = 1 To UBound(ArrayOfPowSets(maxRow, i))
ReDim Preserve nextComb(1 To count2)
nextComb(count2) = ArrayOfPowSets(maxRow, i)(j)
count2 = count2 + 1
Next j
totalCombs = totalCombs + 1
ReDim Preserve myCombs(1 To totalCombs)
myCombs(totalCombs) = nextComb
Next i
k = maxRow - 1
Do While (ArrCounter(k) >= ArrMax(k))
ArrCounter(k) = 1
k = k - 1
If k = 0 Then Exit Do
Loop
If k > 0 Then ArrCounter(k) = ArrCounter(k) + 1 Else CombExist = False
Loop
Sheets("Sheet2").Select
For i = 1 To totalCombs
For j = 1 To UBound(myCombs(i))
Cells(i, j) = myCombs(i)(j)
Next j
Next i
End Sub
I used a slightly modified version of the power set function written by John Coleman found here
Function PowerSet(Items As Variant) As Variant
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset() As Variant
n = UBound(Items)
ReDim PS(1 To 1 + 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
ReDim subset(1 To n)
k = 0
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j + 1)
End If
Next j
ReDim Preserve subset(1 To k)
PS(i) = subset
Next i
PowerSet = PS
End Function
This assumes that SetA is on row 1, SetB is on row 2, etc. Observe:
Additionally, the reader should be warned that this may take a while as there is over 14 million possible combinations.
(2^3 - 1) * (2^5 - 1) * (2^16 - 1) = 7 * 31 * 65535 = 14221095
Also, all combinations are written out generically to Sheet2.
I think i found my solution please verify.
First, for each sets, i created all possible combinations and checked the length using the sum of pascal triangle without the null or this formula:
n!/(r!(n-r)!) - 1
e.g.
SetB: [a, b, c, d] -> [a,b,c,d,ab,ac,ad,bc,bd,cd,abc,abd,acd,bcd,abcd]
After creating all possible combinations for each sets, I just used product rule
[SetA] X [SetB] X [SetC]
Which resulted for all possible combinations for:
multiple items
multiple sets
no repeat
no order
Reference: https://www.mathsisfun.com/combinatorics/combinations-permutations-calculator.html
EDIT1: checking for amount of combinations per set can also be (2^n)-1 where n= length of set
Have you tried using nested for loops.
Sub Hello()
MsgBox ("Hello, world!")
Dim arr1
arr1 = Array("1", "2", "3")
Dim arr2
arr2 = Array("a", "b", "c")
Dim arr3
arr3 = Array("!", "#", "$")
For i = 0 To UBound(arr1)
For j = 0 To UBound(arr2)
For k = 0 To UBound(arr3)
MsgBox (arr1(i) & arr2(j) & arr3(k))
Next
Next
Next
End Sub
I'd like to concatenate some values with same ID:
ID Value1 Value2 Value3
1 Red
2 Black
3 Blue
1 High
2 Tall
4 left
My final table should be:
ID Value1 Value2 Value3
1 Red High
2 Black Tall
3 Blue
4 left
I tried the piece of code below, it work with a simple exemple but not with my data:
Sub Concatene()
Dim I As Integer, Txt As String
Dim e As Integer, y As Integer
Sheets("ARTICLE").Select
For I = Range("A1").SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
Txt = LCase(Cells(I, 1).Value)
If Txt <> "" Then
'Compare other rows
For e = I - 1 To 1 Step -1
If LCase(Cells(e, 1)) = Txt Then
'There is a duplicate
For y = 2 To Cells(I, 1).SpecialCells(xlCellTypeLastCell).Column
'concatenate
If Cells(I, y) <> "" And Cells(e, y) = "" Then
Cells(e, y) = Cells(I, y)
End If
Next y
'Delete row
Rows(I).Delete
End If
Next e
End If
Next I
End Sub
Some help would be great.
Thank in advance and sorry for my bad english.
This will work no matter the size of the list as long as there are no empty rows. It is also much faster than deleting the rows.
Sub CondenseList()
Dim Data, NewData
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
Dim index As Long, x As Long, y As Long
Data = Sheets("ARTICLE").Range("A1").CurrentRegion.Offset(1).Value
ReDim NewData(1 To UBound(Data, 1), 1 To UBound(Data, 2))
For x = 1 To UBound(Data, 1)
If Not list.Contains(Data(x, 1)) Then list.Add Data(x, 1)
index = list.LastIndexOf(Data(x, 1)) + 1
For y = 1 To UBound(Data, 2)
If Data(x, y) <> vbNullString Then NewData(index, y) = Data(x, y)
Next
Next
Sheets("ARTICLE").Range("A1").CurrentRegion.Offset(1).Value = NewData
End Sub
Update: Code breakdown
All the values from the Target range are loaded into the Data array
The NewData array is sized to match the Data array
Next unique ID's are added to an ArrayList
The position off the unique ID's in the ArrayList determines the index that values for that unique ID are written to in the NewData array
Final the NewData array overwrites the values in Target range
Try this
Sub Concatene()
Dim row As Long
Dim row2 As Long
Dim lastrow As Long
Dim used As Long
Dim col As Long
lastrow = Cells(Rows.Count, "A").End(xlUp).row
For row = 2 To lastrow
For row2 = 2 To lastrow
If Cells(row, 1) = Cells(row2, 1) And row <> row2 Then
For col = 2 To 4 'Columns with value. Your example said from column 2 to 4.
If Cells(row, col) = "" Then 'Will only write if its empty
Cells(row, col) = Cells(row2, col)
used = 1 'Line is used...
End If
Next col
If used = 1 Then '...So it can be deleted
used = 0
lastrow = Cells(Rows.Count, "A").End(xlUp).row
Rows(row2).Delete
Exit For
End If
End If
Next row2
Next row
End sub
Aisle 1 Aisle 2 Aisle 3 Aisle 4 Aisle 5 Aisle 6 Aisle 7 Aisle 8 Aisle 9 Aisle 10
Apple Apple Towels Soap Cans Cans Forks Shampoo Toys Chips
Orange Tomato Boxes Clean Bottles Cups Knives B Wash Games Snacks
Pear Potato Plates Spoons Candy
Pina
Above listed are the columns that I need to have all possible combinations.
Here is the macro that i have now:
Sub Aisles()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
For Each c In sht.Range("A4:J4").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("L3").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
There are 2 things that I need help with:
I need to allow only 1 item listed in a column. As it is ,the macro requires at least 2 items to be listed in the column in order to work.
I need the macro to exclude an item once it is chosen: for example in column 1 "apple" is listed and also in column 2. As well is "cans" in columns 5 and 6. Apples can not be stored in 2 different aisles. I guess this might be called a permutation? So the final list of combinations does not have any repeating items.
With no dupes and switching to a 2-d array as the return type, which is much cleaner.
Sub Aisles()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Dim rng As Range
Set sht = ActiveSheet
For Each c In sht.Range("A4:J4").Cells
Set rng = sht.Range(c, sht.Cells(Rows.Count, c.Column).End(xlUp))
If rng.CountLarge > 1 Then
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
Else
'deal with case where there's only a single value in the column
col.Add Array(c.Value)
End If
numCols = numCols + 1
Next c
res = CombineNoDups(col)
sht.Range("L3").Offset(i, 0).Resize(UBound(res, 1), _
UBound(res, 2)).Value = res
End Sub
Function CombineNoDups(col As Collection)
Dim rv(), tmp()
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long, x As Long
Dim numIn As Long, s As String, r As Long, v, dup As Boolean
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(1 To t, 1 To numIn) 'resize destination array
x = 0
For n = 1 To t
ReDim tmp(1 To numIn)
dup = False
For i = 1 To numIn
v = col(i)(pos(i))
If Not IsError(Application.Match(v, tmp, 0)) Then
dup = True
Exit For
Else
tmp(i) = v
End If
Next i
If Not dup Then
x = x + 1
For i = 1 To numIn
rv(x, i) = tmp(i)
Next i
End If
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
CombineNoDups = rv
End Function