I have a set of numbers, 1-33. I need a fast way to generate every permutation of three of these numbers that results in an ascending order.
Examples:
7 19 25
1 2 3
10 20 30
But not:
7 5 9
11 23 22
Is there a way to do this in Excel?
Thanks
This will generate all 5456 combinations of the integers from 1 to 33
Sub ListUm()
Dim i As Long, j As Long, k As Long, Z As Long
Z = 1
For i = 1 To 31
For j = i + 1 To 32
For k = j + 1 To 33
Cells(Z, 1) = i & "," & j & "," & k
Z = Z + 1
Next k
Next j
Next i
End Sub
Since you have a specified order you can use combinations rather than permutations.
Something like this perhaps?
Sub Testing123()
Dim seedMax As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
seedMax = 33
For a = 1 To seedMax
For b = a + 1 To seedMax
For c = b + 1 To seedMax
Debug.Print a, b, c
Next c
Next b
Next a
End Sub
Writing it to a worksheet:
Sub Testing123withSheetWrite()
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim seedMax As Integer: seedMax = 33
Dim x As Long: x = 1
Dim y As Long: y = 1
For a = 1 To seedMax
For b = a + 1 To seedMax
For c = b + 1 To seedMax
Debug.Print a, b, c
Cells(x, y + 0) = a
Cells(x, y + 1) = b
Cells(x, y + 2) = c
x = x + 1
Next c
Next b
Next a
End Sub
Initialize A1,B1,C1 with 1,2,3,
then enter
=IF((B1=32)*(C1=33),A1+1,A1)
in A2,
=IF(A2=A1,IF(C1<33,B1,B1+1),A2+1)
in B2 and
=MAX(B2+1,MOD(C1,33)+1)
in C2
Then copy/drag cells A2:C2 down until the last line, 31,32, 33:
Related
I modified this vba code to generate combinations of six from 10 groups of pairs where only one number of a pair is used for each combination. but I can't get exactly what i want, and there many repetitions of the same combinations and some numbers are not even used in combinations. Can I get a little help to fix this code, please? thanks.
Here is the vba:
Sub Combs()
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim h As Long
Dim j As Long
Dim k As Long
Dim i As Long
Dim grp
grp = Range("B1:C10").Value
Dim arr(1 To 1025, 1 To 10) As Long
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
For g = 1 To 2
For h = 1 To 2
For j = 1 To 2
For k = 1 To 2
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
arr(i, 7) = grp(7, g)
arr(i, 8) = grp(8, h)
arr(i, 9) = grp(9, j)
arr(i, 10) = grp(10, k)
Next k
Next j
Next h
Next g
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Here is a sample data:
Group1 1 2
Group2 3 4
Group3 5 6
Group4 7 8
Group5 9 10
Group6 11 12
Group7 13 14
Group8 15 16
Group9 17 18
Group10 19 20
I'm guessing your want to randomly select 6 from 10
Sub Combos()
Dim i As Integer, j As Integer, k As Integer, n As Integer
Dim c As Integer, digit As Integer
Dim b As String, bb As String
Dim grp, arr(1 To 1025, 1 To 10) As Long, cols
' group data
grp = Range("B1:C10").Value
For j = 0 To 31
b = CStr(WorksheetFunction.Dec2Bin(j, 5))
For k = 0 To 31
bb = b & CStr(WorksheetFunction.Dec2Bin(k, 5))
i = j * 32 + k + 1
' select 6 of the 10 columns
cols = SixFromTen
Range("V" & i + 1) = Join(cols, ",") ' show combo
For c = 0 To 5
n = cols(c) '
'Debug.Print j, k, n
digit = CInt(Mid(bb, n, 1)) ' binary digit
arr(i, c + 1) = grp(n, digit + 1)
Next
Next
Next
Range("O2").Resize(1025, 6).Value = arr
MsgBox "Done"
End Sub
Function SixFromTen() As Variant
Dim num As New Collection, ar(5) As String
Dim i As Integer, n As Integer
Dim a As Integer, b As Integer, tmp As Integer
For n = 1 To 10
num.Add n
Next
For i = 0 To 5
n = 1 + Int(Rnd() * num.Count)
ar(i) = num(n)
num.Remove n
Next
'bubble sort
For a = 0 To 4
For b = a + 1 To 5
If CInt(ar(a)) > CInt(ar(b)) Then
tmp = ar(a)
ar(a) = ar(b)
ar(b) = tmp
End If
Next
Next
SixFromTen = ar
End Function
Alternatively remove 4 from 10 to leave 6 in correct order.
Function SixFromTen() As Variant
Dim num As New Collection, ar(5) As String
Dim i As Integer, n As Integer
For n = 1 To 10: num.Add n: Next
' remove 4
For i = 0 To 3
n = 1 + Int(Rnd() * num.Count)
num.Remove n
Next
For i = 0 To 5: ar(i) = num(i + 1): Next
SixFromTen = ar
End Function
As AcsErno pointed out, the issue is that your program is generating ten columns of digits but the output is only for six columns. Removing four columns results in many repeated combinations because the unique part has been removed in those four columns.
The solution is to only generate six columns, therefore allowing each of them to remain unique. I have rewritten your program to only generate six columns:
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:C6").Value
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Note: The upper bound of the array can be reduced from 1025 since we are no longer using as many rows. If you require additional combinations, you can add a third number to any of the pairs.
An Example:
How to input the combination numbers
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:E6").Value 'Increasing the width
For a = 1 To 2
For b = 1 To 2
For c = 1 To 4 'Changed from 2 to 4
For d = 1 To 4 'Changed from 2 to 4
For e = 1 To 4 'Changed from 2 to 4
For f = 1 To 4 'Changed from 2 to 4
i = i + 1
arr(i, 1) = grp(1, a)
arr(i, 2) = grp(2, b)
arr(i, 3) = grp(3, c)
arr(i, 4) = grp(4, d)
arr(i, 5) = grp(5, e)
arr(i, 6) = grp(6, f)
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
After reading your comments I think I better understand what you are looking for. It sounds like you want the combination to be a subset of six numbers from a set of ten. And each of those ten numbers is one of two values. If I understand that correctly, your issue is that you are having trouble iterating the six columns from the set of ten.
I replaced four of your For Loops with one that loops through the columns instead:
Sub Combs()
Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, alt As Long
Dim i As Long, arr(1 To 1025, 1 To 6) As Long
Dim grp() As Variant
grp = Range("B1:c10").Value
For a = 1 To 2
For b = 1 To 2
For c = 1 To 2
For d = 1 To 2
For e = 1 To 2
For f = 1 To 2
For alt = 0 To 4
'Interating the used section through the full 10 columns.
'Only six columns are used in each combo, but we change which six are used from those 10
i = i + 1
arr(i, 1) = grp(1 + alt, a)
arr(i, 2) = grp(2 + alt, b)
arr(i, 3) = grp(3 + alt, c)
arr(i, 4) = grp(4 + alt, d)
arr(i, 5) = grp(5 + alt, e)
arr(i, 6) = grp(6 + alt, f)
Next alt
Next f
Next e
Next d
Next c
Next b
Next a
Application.ScreenUpdating = False
Range("H2").Resize(1025, 6).Value = arr
Application.ScreenUpdating = True
End Sub
Note: This produces 320 unique combinations. This is not all possible combinations with these number pairs, for a more complete list, you could add in additional arrays with column positions swapped.
Ok, I have the code below, which takes 18 different words, all in Column A rows 1 to 18, and tries them in all different combos to find a seven word palindrome. I am pretty sure the code will get it done, but it just searches for a LONG time. I know there's a way to check the first and last letters of the combos, to make sure they're the same, before the code runs them through the REVERSE function, I just can't figure out how to do it. I am very new to this.In other words, each time it puts together 7 of the words, if it didn't have to go through the REVERSE function, a ton of time would be saved, and verification that the first and last letters match would do that. Thanks in advance for any help
Sub SevenDrome()
Dim count As Integer
count = 0
Dim wordtest As String
Dim wordpal As String
For j = 1 To 18
For k = 1 To 18
For l = 1 To 18
For m = 1 To 18
For n = 1 To 18
For o = 1 To 18
For p = 1 To 18
wordtest = Cells(j, 1) & Cells(k, 1) & Cells(l, 1) & Cells(m, 1) & Cells(n, 1) & Cells(o, 1) & Cells(p, 1)
wordpal = REVERSE(wordtest)
If wordtest = wordpal Then
count = count + 1
Cells(count, 7) = wordtest
End If
Next p
Next o
Next n
Next m
Next l
Next k
Next j
End Sub
Try, This results in 104,976 which takes less than 2 seconds.
Sub test()
Dim a(1 To 18)
Dim vR(1 To 1000000, 1 To 1)
Dim cnt As Long
Dim i As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, o As Integer
For i = 1 To 18
a(i) = Range("a" & i)
Next i
For j = 1 To 18
For k = 1 To 18
If a(j) = a(k) Then
For l = 1 To 18
For m = 1 To 18
If a(l) = a(m) Then
For n = 1 To 18
For o = 1 To 18
If a(n) = a(o) Then
For p = 1 To 18
cnt = cnt + 1
vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
DoEvents
Next p
End If
Next o
Next n
End If
Next m
Next l
End If
Next k
Next j
Range("g1").Resize(cnt) = vR
End Sub
Data image
Result Image
If each cell has more than 2 characters, you can do as follows.
Sub test2()
Dim a(1 To 18)
Dim vR(1 To 1000000, 1 To 1)
Dim cnt As Long
Dim i As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, o As Integer
For i = 1 To 18
a(i) = Range("a" & i)
Next i
For j = 1 To 18
For k = 1 To 18
If a(j) = Reverse(a(k)) Then
For l = 1 To 18
For m = 1 To 18
If a(l) = Reverse(a(m)) Then
For n = 1 To 18
For o = 1 To 18
If a(n) = Reverse(a(o)) Then
For p = 1 To 18
If a(p) = Reverse(a(p)) Then
cnt = cnt + 1
vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
DoEvents
End If
Next p
End If
Next o
Next n
End If
Next m
Next l
End If
Next k
Next j
Range("g1").CurrentRegion.Clear
If cnt Then
Range("g1").Resize(cnt) = vR
End If
End Sub
Function Reverse(s)
Dim i As Integer
Dim myS As String
For i = Len(s) To 1 Step -1
myS = myS & Mid(s, i, 1)
Next i
Reverse = myS
End Function
Case 2 Data
Case 2 Result
I am trying to find the cell references for the largest n length contiguous subset of values in my range.
A similar question has been posted before, ( the link ) however it only returned the sum of the subset, how would I find the specific cell references?
For example, if n = 3, the largest subset range would be A3:A5
Cell Value
A1 2
A2 5
A3 8
A4 2
A5 9
A6 7
A7 2
A8 9
A9 5
A10 3
Below is the code by Excel Hero from the shared link above which returns the sum of the subset
Function MaxN(n&, r As Range)
Dim i&, j&, m#, t#, v
v = r.Value2
For i = 1 To UBound(v)
If UBound(v) - i + 1 >= n Then
t = 0
For j = i To i + n - 1
t = t + v(j, 1)
Next
If t > m Then m = t
Else
Exit For
End If
Next
MaxN = m
End Function
Use this:
Function MaxN(n&, r As Range)
Dim i&, j&, m#, t#, v, str
v = r.Value2
For i = 1 To UBound(v)
If UBound(v) - i + 1 >= n Then
t = 0
For j = i To i + n - 1
t = t + v(j, 1)
Next
If t > m Then
m = t
str = i
End If
Else
Exit For
End If
Next
MaxN = Range(Cells(str, r.Column), Cells(str + n, r.Column)).Address
End Function
I am new to Excel VBA and I want to calculate the distance between two atoms and make a loop to calculate it for all wanted cases
with coordinate B(i), C(i), D(i) in the Excel sheet correspond to x,y,z cartesian coordinate..
these atoms are located : One in a row (i) and the other in a row (i+5)
I write this algorithm but I cant transfer it to excel VBA
For i=4 to 1000
For j=9 to 1000
d=SQRT(POWER(B(i)-B(j),2)+ POWER(C(i)-C(j),2)+ POWER(D(i)-D(j),2))
print **d** in (P(i)) #want to print the distance **d** in a case
j=j+4 # **j** is a multiple of 4
i=i+4 # **i** is a multiple of 4
next i
Thanks, this is my first question
I think that the following should work for you:
Sub FindDistances()
Dim i As Long, j As Long
Dim r As Long, c As Long 'row and column indices for output
Dim data As Variant
Application.ScreenUpdating = False 'useful when doing a lot of writing
data = Range("B4:D1000").Value 'data is a 1-based array
c = 5 'column E
For i = 1 To UBound(data) - 5 Step 4
r = 1 'first row printed in -- adjust if need be
For j = i + 5 To UBound(data) Step 4
Cells(r, c).Value = Sqr((data(i, 1) - data(j, 1)) ^ 2 + (data(i, 2) - data(j, 2)) ^ 2 + (data(i, 3) - data(j, 3)) ^ 2)
r = r + 1
Next j
c = c + 1
Next i
Application.ScreenUpdating = True
End Sub
Something like this? In VBA, you refer to cells like Cells(row, column). Data is supposed to be located in a worksheet named Sheet1. I'm calculating each dimension separately (d1, d2, d3) just for reading simplicity. You can merge those four lines in one if you like. EDIT: reading your comments above, I add a nested loop (j).
Sub Distances()
Dim i As Integer
Dim j As Integer
Dim d1 As Double, d2 As Double, d3 As Double, d As Double
For i = 4 To 1000 Step 4 'Can't understand your data, but Step 4 tries to account for your j=j+4 and i=i+4
For j = 9 To 1000 Step 4
d1 = (Worksheets("Sheet1").Cells(i, 2) - Worksheets("Sheet1").Cells(j, 2)) ^ 2
d2 = (Worksheets("Sheet1").Cells(i, 3) - Worksheets("Sheet1").Cells(j, 3)) ^ 2
d3 = (Worksheets("Sheet1").Cells(i, 4) - Worksheets("Sheet1").Cells(j, 4)) ^ 2
d = Sqr(d1 + d2 + d3)
Worksheets("Sheet1").Cells(i, 16).Value = d
Next j
Next i
End Sub
Option Explicit
Sub AtomDistance()
'
' AtomDistance Macro1
'
'
Dim i As Integer
Dim j As Integer
Dim Distance As Double
Dim Column As String
Column = InputBox("Which column you want to print results(put a letter)?")
Dim MyCell11 As String
Dim MyCell12 As String
Dim MyCell13 As String
Dim MyCell21 As String
Dim MyCell22 As String
Dim MyCell23 As String
Dim MyCell3 As String
j = 9
For i = 4 To 12
MyCell3 = Column & i
MyCell11 = "B" & i
MyCell12 = "C" & i
MyCell13 = "D" & i
MyCell21 = "B" & j
MyCell22 = "C" & j
MyCell23 = "D" & j
Distance = (((Range(MyCell11).Value - Range(MyCell21).Value) ^ 2) + ((Range(MyCell12).Value - Range(MyCell22).Value) ^ 2) + ((Range(MyCell13).Value - Range(MyCell23).Value) ^ 2)) ^ 0.5
If i Mod 4 = 0 Or j Mod 4 = 0 Then
Range(MyCell3).Value = Distance
End If
j = j + 1
Next i
I am stuck on problem where my vba won't increment row number. My tables looks like:
Sheet1
name value
aa 11
bb 12
cc 13
aa 14
cc 15
cc 16
aa 17
bb 18
aa 19
Sheet2
name
aa
bb
cc
I need to search for each specific value, if found copy adjacent cell to sheet2 right next searched value. This is code doing but problem is with row incrementation, all searched values are in one row (variable k is not working).
Sub finall()
Dim cable As String
Dim finalrow1 As Integer
Dim finalrow2 As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
l = 2
k = 2
finalrow2 = Sheets("Sheet2").Range("A1000").End(xlUp).Row
finalrow1 = Sheets("Sheet1").Range("A1000").End(xlUp).Row
For j = 2 To finalrow2
cable = Sheets("Sheet2").Cells(j, 1).Value
For i = 2 To finalrow1
If Cells(i, 1) = cable Then
Sheets("Sheet1").Cells(i, 2).Copy
Sheets("Sheet2").Cells(k, l).End(xlUp).Offset(1, 0).PasteSpecial
l = l + 1
End If
Next i
k = k + 1
Next j
End Sub
This is only example in final i want to apply this code to table with 50-60k rows.
Final table should look like:
name
aa 11 14 17 19
bb 12 18
cc 13 15 16
Thx
Final code would be as below
Sub finall()
Dim cable As String
Dim finalrow1 As Long
Dim finalrow2 As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
l = 2
k = 2
finalrow2 = Sheets("Sheet2").Range("A1000").End(xlUp).Row
finalrow1 = Sheets("Sheet1").Range("A1000").End(xlUp).Row
Worksheets("Sheet2").Select
For j = 2 To finalrow2
cable = Sheets("Sheet2").Cells(j, 1).Value
For i = 2 To finalrow1
If Sheets("Sheet1").Cells(i, 1) = cable Then
Sheets("Sheet1").Cells(i, 2).Copy
Sheets("Sheet2").Cells(k, l).PasteSpecial
l = l + 1
End If
Next i
k = k + 1
l = 2
Next j
End Sub
Proof of work