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.
Related
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 have to print the sequential 25 prime numbers after I ask the user to input a number. The code below indeed does print prime numbers but it prints empty spaces. I can't figure out how to make it print ONLY the prime numbers and no empty spaces. I have this thus far:
Public Function IsPrime(value)
Dim remainder As Double
Dim rounded As Long
Dim Max As Long
Dim j As Long
IsPrime = 0
Max = 1 + Int(value / 2)
For j = 2 To Max
rounded = Int(value / j)
remainder = (value / j) - rounded
If remainder = 0 Then
Exit For
End If
Next j
If j = Max + 1 Or value = 2 Then
IsPrime = 1
End If
If value <= 1 Then
IsPrime = 0
End If
End Function
Public Sub printprime()
Dim x As Integer
Dim row As Integer
Dim col As Integer
Dim j As Integer
Dim matrix1(1 To 5, 1 To 5) As Integer
x = InputBox("Please enter a number ")
j = 1
For row = 1 To 5
For col = 1 To 5
If IsPrime(x + j) = 1 Then
Cells(row, col) = x + j
matrix1(row, col) = Cells(row, col)
End If
j = j + 1
Next col
Next row
You just need to keep going and only record the primes:
Public Sub printprime()
Dim x As Long
Dim row As Long
Dim col As Long
Dim j As Long
x = InputBox("Please enter a number ")
row = 1
col = 1
For j = x + 1 To 9999
If IsPrime(j) Then
Cells(row, col) = j
col = col + 1
If col = 6 Then
col = 1
row = row + 1
End If
If row = 7 Then Exit Sub
End If
Next j
End Sub
Here's my version
Sub print_prime()
Dim i As Integer
Dim j As Integer
Dim if_prime As Boolean
Dim Count
Count = InputBox("Enter Max Number")
For i = 2 To Count
if_prime = True
If i = 2 Then GoTo nextItem
For j = 2 To i - 1
If i Mod j = 0 Then
if_prime = False
GoTo nextItem
End If
Next j
nextItem:
If if_prime Then Debug.Print i
Next i
End Sub
In excel, I have column 1 with tickers, and column 2 with numbers, like this:
A B
1 AAA 10
2 AAA 12
3 AAA 14
4 BBB 9
5 BBB 10
6 BBB 11
I need a piece of code to calculate average BY TICKER, which means that in this case I would have AAA average : 12 and BBB average = 10, etc etc etc. Up to now all i got is this code which tries to calculate the sums, I will do the divisions later, but something's wrong:
For row = 2 to 6
Ticker = Cells(row - 1, 1)
If Cells(row, 1) = Cells(row - 1, 1) Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
row = row + 1
Next
I get an error saying "For is missing"
Maybe something like this in C1.
=IF(A1<>A2,AVERAGEIF(A:A,A1,B:B),"")
In your code:
sum ignored the first AAA
missed the End If
incremented row twice, once by row = row+1 and then by next
and some other not used variables
Try this:
Prev = "***"
For row = 1 to 6
If Cells(row, 1) = prev Then
sum = sum + Cells(row, 2)
Else
Cells(row, 6) = sum
sum = 0
End If
prev = Cells(row,1)
Next
To extend the answer from Jeeped and do it with a list which is not ordered, you also could do it like this:
C1: =A1
C2: =IF(LEN(C1),IFERROR(INDEX(A:A,MATCH(1,(COUNTIF(C$1:C1,A$1:A$1000)=0)*(A$1:A$1000<>""),0)),""),"")}
C3....Cn: copy down from C2
D1: =IF(LEN(C1),AVERAGEIF(A:A,C1,B:B),"")
D2...Dn: copy down from D1
C2 is an array formula and needs to be confirmed with Ctrl+Shift+Enter
to do it via VBA (should be faster than my formula for really big tables) you can use something like that: (put this in a "Module" in the VBA-Window, the same like your recorded macros ar written)
Option Explicit
Public Function getAllAvg(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
j = 1
While Len(varOutput(j, 1)) And (varOutput(j, 1) <> varInput(i, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
varOutput(j + 1, 1) = ""
End If
End If
Next
While Len(varOutput(j, 1)) And (j < UBound(varOutput))
j = j + 1
Wend
If Len(varOutput(j, 1)) = 0 Then
For i = j To UBound(varOutput)
varOutput(i, 1) = ""
varOutput(i, 2) = ""
Next
End If
getAllAvg = varOutput
End Function
then select a range like C2:D12 and enter:
=getAllAvg(A:B)
and confirm with Ctrl+Shift+Enter. it will directly output the whole list (and recalculate if needed)
EDIT:
If your list is always in a sorted order, you also could use this code:
Option Explicit
Public Function getAllAvgSorted(rng As Range) As Variant
Set rng = Intersect(rng.Parent.UsedRange, rng)
Dim varInput As Variant
varInput = rng.Value
Dim varOutput() As Variant
ReDim varOutput(1 To UBound(varInput), 1 To 2)
varOutput(1, 1) = ""
Dim i As Long, j As Long
j = 1
For i = 1 To UBound(varInput)
If Len(varInput(i, 1)) Then
If varOutput(j, 1) <> varInput(i, 1) Then
If Len(varOutput(j, 1)) Then j = j + 1
varOutput(j, 1) = varInput(i, 1)
varOutput(j, 2) = Application.AverageIf(rng.Columns(1), varOutput(j, 1), rng.Columns(2))
End If
End If
Next
While j < UBound(varOutput)
j = j + 1
varOutput(j, 1) = ""
varOutput(j, 2) = ""
Wend
getAllAvgSorted = varOutput
End Function
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