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.
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").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("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
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
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
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
thanks in advance for taking the time to help. I have built a Do While loop in VBA that for some reason breaks when j = 1. I have in cells C3:C7 these values: 13,14,14,13,14.
Here's the short script:
Dim i, j, n As Integer
Dim List(0) As Integer
i = o
j = 0
n = 0
Do While Cells(i + 3, 3) <> ""
If Cells(i + 3, 3) > 13 Then
List(j) = i + 3
j = j + 1
Cells(i + 3, 4) = "Noted"
i = i + 1
ElseIf Cells(i + 3, 3) = 13 Then
Cells(i + 3, 4) = "Skipped"
i = i + 1
Else
i = i + 1
End If
Loop
For n = j To n = 0
Rows(List(n)).Delete
Next
Thanks again!
Your intent is sound, but there are quite a few errors. See commented code below for details
Sub Demo()
' ~~ must explicitly type each variable. Use Long
Dim i As Long, j As Long, n As Long
Dim List() As Long '<~~ dynamic array
i = 3 '<~~ eliminate the klunky +3
j = 0
n = 0
ReDim List(0 To 0) '<~~ initialise dynamic array
Do While Cells(i, 3) <> vbNullString
If Cells(i, 3) > 13 Then
ReDim Preserve List(0 To j) '<~~ resize array
List(j) = i
j = j + 1
Cells(i, 4) = "Noted"
ElseIf Cells(i, 3) = 13 Then
Cells(i, 4) = "Skipped"
End If
i = i + 1 '<~~ simplify, its called in each if case anyway
Loop
' j will end up 1 greater than size of array
If j > 0 Then '<~~ only execute if we found some rows to delete
For n = j - 1 To 0 Step -1 '<~~ For loop syntax
Rows(List(n)).Delete
Next
End If
End Sub
Sub HMM()
Dim x As Integer
Dim GG As Integer
Dim Gr As Integer
Dim rG As Integer
Dim rr As Integer
For x = 3 To x = 26126
If ActiveSheet.Cells(x, 3) > 0 And ActiveSheet.Cells(x + 1, 3) > 0 Then
GG = GG + 1
End If
If ActiveSheet.Cells(x, 3) > 0 And ActiveSheet.Cells(x + 1, 3) < 0 Then
Gr = Gr + 1
End If
If ActiveSheet.Cells(x, 3) < 0 And ActiveSheet.Cells(x + 1, 3) > 0 Then
rG = rG + 1
End If
If ActiveSheet.Cells(x, 3) < 0 And ActiveSheet.Cells(x + 1, 3) < 0 Then
rr = rr + 1
End if
Next x
With ActiveSheet
.Cells(2, 30) = GG
.Cells(3, 30) = Gr
.Cells(4, 30) = rG
.Cells(5, 30) = rr
End With
End Sub
So i have a long list of numbers ranging from C3 to C26126. What I need to do is find out how many times a positive number precedes a positive number (GG), how many times a negative number precedes a positive number (rG), etc. So I need GG Gr rG and rr. Sorry if this isn't clear enough.
Example: I have a table y: [-1,2,2,3,-1,-2,2] GG = 2, Gr = 1, rG = 2, rr = 1
My ultimate goal is to find a simple hidden markov model for my time series.
Sub Tester()
Dim pp, pn, np, nn, x, arr, v1, v2
arr = ActiveSheet.Range("C3:C1110").Value
For x = 1 To UBound(arr, 1) - 1
v1 = arr(x, 1): v2 = arr(x + 1, 1)
If v1 > 0 And v2 > 0 Then
pp = pp + 1
ElseIf v1 > 0 And v2 < 0 Then
pn = pn + 1
ElseIf v1 < 0 And v2 > 0 Then
np = np + 1
ElseIf v1 < 0 And v2 < 0 Then
nn = nn + 1
End If
Next x
Debug.Print pp, pn, np, nn
End Sub
Not too sure what the question is .... since you've already given an answer
Sub HMM()
Dim myWS As Worksheet
Set myWS = Worksheets("Sheet1")
Dim x As Integer
Dim GG As Integer
Dim Gr As Integer
Dim rG As Integer
Dim rr As Integer
'Initially 0 by default but it's always good to be explicit
GG = 0
Gr = 0
rG = 0
rr = 0
'Count from 3 to 26125 instead of from 3 to 26126
With myWS
For x = 3 To 26125
If .Cells(x, 3).Value > 0 Then
If .Cells(x + 1, 3).Value > 0 Then
GG = GG + 1
ElseIf .Cells(x + 1, 3).Value < 0 Then
Gr = Gr + 1
End If
ElseIf .Cells(x, 3).Value < 0 Then
If .Cells(x + 1, 3).Value > 0 Then
rG = rG + 1
ElseIf .Cells(x + 1, 3).Value < 0 Then
rr = rr + 1
End If
End If
Next x
Debug.Print GG, Gr, rG, rr
End With
End Sub
If I were you, I would set .Cells(x+1,3) to a variable and then compare.. But I was not sure which variable type I should use since there is a limit to everything..