I want to make a sub, which determines if the cells in the 12th column starts with 262015. If it does start with this, it should create a new random 8-digit number starting with "18" and then 6 randomly created unique digits.
My code does not seem to figure out if the cell starts with 262015, and I have not been able to find help on creating the 8-digit number with these requirements.
Hope you can help me!
Sub Opgave8()
For i = 2 To 18288
If Left(Worksheets("arab").Cells(i, 12), 6) = "262015" Then
Worksheets("arab").Cells(i, 3) = "18" & studyid(6)
End If
Next i
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
End Sub
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
Worksheets("Base").Cells(i, 3) = "18" & Randdigits(6)
End If
Next i
Function RandDigits(x As Long) As String
Dim i As Long
Dim s As String
For i = 1 To x
s = s & Int(Rnd() * 10)
Next i
RandDigits = s
End Function
EDIT: here's one where all digits are different
Function UniqueRandDigits(x As Long) As String
Dim i As Long
Dim n As Integer
Dim s As String
Do
n = Int(Rnd() * 10)
If InStr(s, n) = 0 Then
s = s & n
i = i + 1
End If
Loop Until i = x + 1
UniqueRandDigits = s
End Function
EDIT2: And here is one that forces all numbers to be different
dim n as string
dim ok as boolean
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
ok = false
do
n = UniqueRandDigits(6)
If Application.WorksheetFunction.CountIf(Worksheets("Base").Range("L2:L18288"), n) = 0 Then
Worksheets("Base").Cells(i, 3) = "18" & n
ok = true
end if
loop until ok
End If
Next i
Using Left function, you need to specify the String, then the number of characters from the left, and then you check if it's equal to "262015".
Try the code below:
For i = 2 To 18288
If Left(Worksheets("Base").Cells(i, 12), 6) = "262015" Then
Worksheets("Base").Cells(i, 3) = "XXX"
End If
Next i
Related
I could not find any information on this problem in the Visual Basic language, but I am trying to generate 10 and only 10 random mines for a 5x5 Minesweeper game. My problem involves the number of mines. I often only generate 4 mines, or 10+ mines, and its always inconsistent. Here is my code:
Sub Minesweeper()
Dim i As Single
Dim Col As Single
Dim Row As Single
Dim BombArray(1 To 5, 1 To 5) As String
'assignment of mines
Do
Row = Application.WorksheetFunction.RandBetween(1, 5)
Col = Application.WorksheetFunction.RandBetween(1, 5)
1
If BombArray(Row, Col) <> "X" Then
BombArray(Row, Col) = "X"
Sheet1.Cells(4 + Row, 3 + Col).Value = BombArray(Row, Col)
Else
i = i + 1
GoTo 1
End If
Loop Until i = 10
End Sub
Any help would be greatly appreciated.
Use a standard for loop
Also since you are using an array assign the array only once after the loop:
Sub Minesweeper()
Dim i As Single
Dim Col As Single
Dim Row As Single
Dim BombArray(1 To 5, 1 To 5) As String
'assignment of mines
For i = 1 To 10
Row = Application.WorksheetFunction.RandBetween(1, 5)
Col = Application.WorksheetFunction.RandBetween(1, 5)
If BombArray(Row, Col) <> "X" Then
BombArray(Row, Col) = "X"
Else
i = i - 1
End If
Next i
Sheet1.Range("D5").Resize(UBound(BombArray, 1), UBound(BombArray, 2)).Value = BombArray
End Sub
Build a dictionary of mine locations and keep adding/overwriting until you reach 10.
Option Explicit
Sub Minesweeper()
Dim mines As Object
Set mines = CreateObject("scripting.dictionary")
Do While mines.Count < 10
mines.Item(Cells(Application.RandBetween(5, 9), Application.RandBetween(4, 8)).Address(0, 0)) = vbNullString
Loop
Debug.Print Join(mines.keys, ", ")
Sheet1.Range(Join(mines.keys, ", ")) = "x"
End Sub
This program was made with Excel Visual Basic and should count the frequenzy of the letters that appear in a word you write into the A-1 cell.
For example apple - 1x a, 1x e, 1x l, 2x p, and the rest 0x
Public Sub Test()
Dim word As String
Dim wordarr(999) As String
Dim alph(1 To 29) As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
i = 1
j = 1
k = 1
m = 1
With ThisWorkbook.Worksheets("Tabelle1")
word = .Cells(1, 1)
'clearing the columns to rewrite it
.Columns(3).EntireColumn.Clear
.Columns(4).EntireColumn.Clear
'initializing my alphabet array
alph(1) = "a": alph(2) = "b": alph(3) = "c": alph(4) = "d": alph(5) = "e": alph(6) = "f":
alph(7) = "g": alph(8) = "h": alph(9) = "i": alph(10) = "j": alph(11) = "k": alph(12) = "l":
alph(13) = "m": alph(14) = "n": alph(15) = "o": alph(16) = "p": alph(17) = "q": alph(18) = "r":
alph(19) = "s": alph(20) = "t": alph(21) = "u": alph(22) = "v": alph(23) = "w": alph(24) = "x":
alph(25) = "y": alph(26) = "z": alph(27) = "_": alph(28) = "-": alph(29) = " "
'filling up the C column with my alphabet array
For i = 1 To 29
.Cells(i, 3) = alph(i)
Next i
'converting the string word into an array
For j = 1 To Len(word)
wordarr(j) = Mid(word, j, 1)
If j = Len(word) Then
Exit For
End If
Next j
'counting the frequency of each letter in the word and writing it into
'the column next to it
For m = 1 To 29
For k = 1 To Len(word)
If alph(m) = wordarr(k) Then
.Cells(m, 4) = .Cells(m, 4).Value + 1
End If
Next k
Next m
End With
End Sub
The program is working, but it isn't working fine i guess. Do you have any suggestions on how to optimize it without over-complicating it too much, I'm pretty new to this language. Is there also another way of initializing the array. I have tried several ways but it more often than not didn't work.
I am looking forward to seeing your suggestions.
here is another
i added a conversion to lower case so that uppercase characters are also counted
also added counting of "*", just as an example
Public Sub Test()
Dim word As String
Dim letter As String
Dim pointer As Integer
Dim i As Integer
With ThisWorkbook.Worksheets("Tabelle1")
word = LCase(.Cells(1, 1)) ' change text to all lower case
.Columns(3).EntireColumn.Clear ' clearing the columns to rewrite it
.Columns(4).EntireColumn.Clear
For i = 1 To 26 ' filling up the C column with my alphabet array
.Cells(i, 3) = Chr(i + 96) ' chr(97)=="a", chr(122)=="z"
Next i
.Cells(27, 3) = "_" ' oddballs
.Cells(28, 3) = "-"
.Cells(29, 3) = "<space>"
.Cells(30, 3) = "*"
For i = 1 To Len(word) ' scan text and update cells as you go
letter = Mid(word, i, 1)
' If i = Len(word) Then ' "for .. next" command already does this
' Exit For
' End If
Select Case letter
Case "a" To "z"
pointer = Asc(letter) - 96 ' asc("a")==97, asc("z")==122
Case "_"
pointer = 27
Case "-"
pointer = 28
Case " "
pointer = 29
Case "*"
pointer = 30
Case Else
GoTo skip_cell_update ' this character is not counted
End Select
.Cells(pointer, 4) = .Cells(pointer, 4).Value + 1 ' increment cell
skip_cell_update:
Next i
End With
End Sub
Here is soemthing short and sweet that im sure youll be able to expand upon quite easily
Private Sub THIS()
Dim Char As String, compareString As String, testString As String
Dim strCount As Long, i As Long, j As Long, y As Long, rCount As Long
Dim arr(28, 1) As String
testString = ThisWorkbook.Sheets("Sheet1").Range("a1").Value
For i = 1 To Len(testString)
Char = Mid(testString, i, 1)
For j = 1 To Len(testString)
For y = LBound(arr, 1) To UBound(arr, 1)
If Char = arr(y, 0) Then
GoTo Nexti
End If
Next y
compareString = Mid(testString, j, 1)
If Char = compareString Then
strCount = strCount + 1
End If
Next j
Debug.Print ; Char
Debug.Print ; strCount
arr(i, 0) = Char
arr(i, 1) = strCount
Nexti:
strCount = 0
Next i
End Sub
I have a function in VBA that makes a few operations by calling other smaller functions. This function doesn't work in any sheets, just in one. In the sheets it doesn't work it just gets out of the whole algorithm when getting the value from another function.
This is my Function determinarCantidadPorPedido(ByVal material As String, ByVal mes As String)
Dim demanda As Double
Dim pProgramado As Double
Dim numPedidos As Integer
demanda = determinarDemanda(material, mes)
Call contarProductosMateriales
Sheets("LlegadaMateriales").Activate
Dim fila As Integer
Dim columna As Integer
For i = 1 To numMateriales Step 1
If Sheets("LlegadaMateriales").Cells(1 + i, 1) = material Then
fila = 1 + i
Exit For
End If
Next
For j = 1 To 12 Step 1
If Sheets("LlegadaMateriales").Cells(1, j + 1) = mes Then
columna = j + 1
Exit For
End If
Next
pProgramado = Sheets("LlegadaMateriales").Cells(fila, columna)
numPedidos = darCantidadPedidos(determinarDiasMes(mes), darLeadTime(material))
determinarCantidadPorPedido = WorksheetFunction.Round((demanda - pProgramado) / numPedidos, 0)
and it calls Public Function determinarDemanda(ByVal material As String, ByVal mes As String) As Double
Dim filaProducto As Double
Dim numMat As Double
Dim columnaDemanda As Double
Worksheets("ProductosYMateriales").Activate
numMat = Sheets("ProductosYMateriales").Range(Cells(3, 1), Cells(3, 1).End(xlDown)).Rows.Count
For i = 1 To numMat Step 1
If Sheets("ProductosYMateriales").Cells(i + 2, 1) = material Then
filaProducto = i + 2
Exit For
End If
Next
For j = 1 To 12 Step 1
If Sheets("Demanda").Cells(1, j + 2) = mes Then
columnaDemanda = j + 2
Exit For
End If
Next
Dim numProd As Double
numProd = Sheets("ProductosYMateriales").Range(Cells(2, 2), Cells(2, 2).End(xlToRight)).Columns.Count
Dim demanda As Double
demanda = 0
For k = 1 To numProd Step 1
Dim x As Double
x = Sheets("Demanda").Cells(k + 1, columnaDemanda)
Dim y As Double
y = Sheets("ProductosYMateriales").Cells(filaProducto, k + 1)
Dim prod As Double
prod = x * y
demanda = demanda + prod
Next
determinarDemanda = demanda
and Function determinarCantidadPorPedido(ByVal material As String, ByVal mes As String)
Dim demanda As Double
Dim pProgramado As Double
Dim numPedidos As Integer
demanda = determinarDemanda(material, mes)
Call contarProductosMateriales
Sheets("LlegadaMateriales").Activate
Dim fila As Integer
Dim columna As Integer
For i = 1 To numMateriales Step 1
If Sheets("LlegadaMateriales").Cells(1 + i, 1) = material Then
fila = 1 + i
Exit For
End If
Next
For j = 1 To 12 Step 1
If Sheets("LlegadaMateriales").Cells(1, j + 1) = mes Then
columna = j + 1
Exit For
End If
Next
pProgramado = Sheets("LlegadaMateriales").Cells(fila, columna)
numPedidos = darCantidadPedidos(determinarDiasMes(mes), darLeadTime(material))
determinarCantidadPorPedido = WorksheetFunction.Round((demanda - pProgramado) / numPedidos, 0)
One Problem is in this Line:
numMat = Sheets("ProductosYMateriales").Range(Cells(3, 1), Cells(3, 1).End(xlDown)).Rows.Count
when you call Cells, this reference the current active sheet. Therefore you will get different results, if you call the function on different sheets.
You will have to specify from what sheets you want to reference the cells. I guess you want this:
numMat = Sheets("ProductosYMateriales").Range(Sheets("ProductosYMateriales").Cells(3, 1), Sheets("ProductosYMateriales").Cells(3, 1).End(xlDown)).Rows.Count
This question already has answers here:
Repeating random variables in VBA
(2 answers)
Closed 7 years ago.
What would be the VBA code in excel to generate ONE random number between 1 to 100 that is displayed in a given cell (say A1) upon clicking a button, and then when the button is clicked again, it generates another random number between 1 to 100, THAT IS NOT A REPETITION. Ideally, this should allow me to click the button a 100 times and get all the numbers between 1-100 exactly once each ?
Technically there is no such thing as random numbers with no repetition. What you are asking for is actually a random permutation of a set of values, like the ordering of a shuffled deck of cards or lottery ball picks. Random permutation of a range of vlaues can be achieved in Excel VBA succinctly.
Assign your button's macro to RangeValue():
Public Sub RangeValue()
Dim i As Long
Static n As Long, s As String
Const MIN = 1, MAX = 100, OUT = "A1", DEL = "."
Randomize
Do
i = Rnd * (MAX - MIN) + MIN
If 0 = InStr(s, i & DEL) Then
n = n + 1: s = s & i & DEL
Range(OUT) = i
If n > MAX - MIN Then n = 0: s = ""
Exit Do
End If: DoEvents
Loop
End Sub
That's it. The above code is all that is required to answer your question as posed.
You can use the Const line near the top to edit the MIN and MAX range of values that will be spun through randomly. You can also adjust the OUTput cell.
Once all of the values have been output (i.e. 100 button clicks), the code resets and spins through the range again in a new, random order. This continues forever. You can disable multiple spins-through by deleting this line: If n > MAX - MIN Then n = 0: s = ""
How does this work?
The routine maintains a string of previously output values. Each time the procedure is run, it selects a new random value from the range and checks if that value is already logged in the string. If it is it picks a new value and looks again. This continues in a loop until a value not currently logged in the string is randomly selected; that value is logged and output to the cell.
EDIT #1
To address your new question about how to set this up so that it works in more than one cell with different value ranges, assign your button's macro to ButtonClick():
Public Sub ButtonClick()
Static n1 As Long, s1 As String, n2 As Long, s2 As String
RangeValue 1, 100, "A1", n1, s1
RangeValue 1, 150, "B1", n2, s2
End Sub
Private Sub RangeValue(MIN As Long, MAX As Long, OUT As String, n As Long, s As String)
Dim i As Long
Const DEL = "."
Randomize
Do
i = Rnd * (MAX - MIN) + MIN
If 0 = InStr(s, i & DEL) Then
n = n + 1: s = s & i & DEL
Range(OUT) = i
If n > MAX - MIN Then n = 0: s = ""
Exit Do
End If: DoEvents
Loop
End Sub
EDIT #2
While the above methods are concise, we can be more efficient by permuting the set of values in an array, and by avoiding the selection of values that have already been output. Here is a version that uses Durstenfeld's implementation of the Fisher–Yates shuffle algorithm:
Public Sub ButtonClick()
Static n As Long, a
Const MIN = 1, MAX = 100, OUT = "A1"
If n = 0 Then a = Evaluate("transpose(row(" & MIN & ":" & MAX & "))"): n = UBound(a)
PermuteArray a, n: Range(OUT) = a(n): n = n - 1
End Sub
Private Sub PermuteArray(a, n As Long)
Dim j As Long, t
Randomize
j = Rnd * (n - 1) + 1
If j <> n Then t = a(j): a(j) = a(n): a(n) = t
End Sub
Fisher–Yates has the advantage that it can be stopped and started as needed and so I am using it on the fly to permute the next value to display on each button click.
And to round this out with a version to use with your scenario of two output cells that use different value ranges:
Public Sub ButtonClick()
Static n1 As Long, n2 As Long, a1, a2
Const MIN1 = 1, MAX1 = 100, OUT1 = "A1"
Const MIN2 = 1, MAX2 = 150, OUT2 = "B1"
If n1 = 0 Then Reset a1, n1, MIN1, MAX1
If n2 = 0 Then Reset a2, n2, MIN2, MAX2
PermuteArray a1, n1: Range(OUT1) = a1(n1): n1 = n1 - 1
PermuteArray a2, n2: Range(OUT2) = a2(n2): n2 = n2 - 1
End Sub
Private Sub PermuteArray(a, n As Long)
Dim j As Long, t
Randomize
j = Rnd * (n - 1) + 1
If j <> n Then t = a(j): a(j) = a(n): a(n) = t
End Sub
Private Sub Reset(a, n As Long, MIN As Long, MAX As Long)
a = Evaluate("transpose(row(" & MIN & ":" & MAX & "))"): n = UBound(a)
End Sub
EDIT #3
I decided to create a version of this that utilizes the "inside-out" variation of Fisher–Yates. This allows us to specify the array of range values and shuffle it at the same time, an elegant and even more efficient enhancement:
Public Sub ButtonClick()
Const MIN = 1, MAX = 100, OUT = "A1"
Static a, n&
If n = 0 Then Reset a, n, MIN, MAX
Range(OUT) = a(n): n = n - 1
End Sub
Private Sub Reset(a, n&, MIN&, MAX&)
Dim i&, j&
Randomize: n = MAX - MIN + 1: ReDim a(1 To n)
For i = 1 To n
j = Rnd * (i - 1) + 1: a(i) = a(j): a(j) = i - 1 + MIN
Next
End Sub
And to expand on your requirement of two different output cells that each use different value ranges, I decided to craft a generalized solution that can be used for an arbitrary number of independent output cells each tied to its own value range:
Public Sub ButtonClick()
Dim MIN, MAX, OUT, i
Static a, n, z
MIN = Array(1, 11, 200): MAX = Array(100, 20, 205): OUT = Array("A1", "B2", "C3")
z = UBound(MIN)
If Not IsArray(n) Then ReDim a(z): ReDim n(z)
For i = 0 To z
If n(i) = 0 Then Reset a(i), n(i), MIN(i), MAX(i)
Range(OUT(i)) = a(i)(n(i)): n(i) = n(i) - 1
Next
End Sub
Private Sub Reset(a, n, MIN, MAX)
Dim i, j
Randomize: n = MAX - MIN + 1: ReDim a(1 To n)
For i = 1 To n
j = Rnd * (i - 1) + 1: a(i) = a(j): a(j) = i - 1 + MIN
Next
End Sub
While the above is setup for three outputs, simply adjust the MIN, MAX, and OUT arrays near the top to suit your needs.
Here's a button click handler that uses static variables to hold an array containing a random sequence of numbers from 1 to 100, as well as the current position/index within that array. The array is created by populating a collection with numbers from 1 to 100, then transferring each number to the array in a random order.
Sub Button1_Click()
Static NumberArray As Variant
Static intIndex As Long
If Not IsArray(NumberArray) Then NumberArray = GetRandomArray()
' If we haven't reached the end of our sequence, get another number...
If intIndex < 100 Then
Sheets("Sheet1").Range("A1") = NumberArray(intIndex)
intIndex = intIndex + 1
End If
End Sub
Function GetRandomArray() As Variant
Dim c As New Collection
Dim a(99) As Long
' Seed the RNG...
Randomize
' Add each number to our collection...
Dim i As Long
For i = 1 To 100
c.Add i
Next
' Transfer the numbers (1-100) to an array in a random sequence...
Dim r As Long
For i = 0 To UBound(a)
r = Int(c.Count * Rnd) + 1 ' Get a random INDEX into the collection
a(i) = c(r) ' Transfer the number at that index
c.Remove r ' Remove the item from the collection
Next
GetRandomArray = a
End Function
Try this:
Dim Picks(1 To 100) As Variant
Dim which As Long
Sub Lah()
Dim A As Range
Set A = Range("A1")
If A.Value = "" Then
which = 1
For i = 1 To 100
Picks(i) = i
Next i
Call Shuffle(Picks)
Else
which = which + 1
If which = 101 Then which = 1
End If
A.Value = Picks(which)
End Sub
Sub Shuffle(InOut() As Variant)
Dim HowMany As Long, i As Long, J As Long
Dim tempF As Double, temp As Variant
Hi = UBound(InOut)
Low = LBound(InOut)
ReDim Helper(Low To Hi) As Double
Randomize
For i = Low To Hi
Helper(i) = Rnd
Next i
J = (Hi - Low + 1) \ 2
Do While J > 0
For i = Low To Hi - J
If Helper(i) > Helper(i + J) Then
tempF = Helper(i)
Helper(i) = Helper(i + J)
Helper(i + J) = tempF
temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = temp
End If
Next i
For i = Hi - J To Low Step -1
If Helper(i) > Helper(i + J) Then
tempF = Helper(i)
Helper(i) = Helper(i + J)
Helper(i + J) = tempF
temp = InOut(i)
InOut(i) = InOut(i + J)
InOut(i + J) = temp
End If
Next i
J = J \ 2
Loop
End Sub
EDIT#1
The code begins by examining the destination cell, A1. If the cell is empty the code:
creates an array of 100 values
randomizes that array
initializes a sequential counter
places the first element of the randomized array in A1
If the cell is not empty, the code just places the next element of the randomized array in A1.
If you want to restart the process, clear A1. This will re-shuffle the array.
Here is an approach that maintains a global collection of available numbers and places #N/A in cells below A100. The button's click() sub makes sure that the collection is initialized when it needs to be. In a standard code module (insert -> module) enter:
Public Available As Collection
Public Initialized As Boolean
Sub Initialize()
Dim i As Long, n As Long
Dim used(1 To 100) As Boolean
Set Available = New Collection
If Not Range("A1").Value < 1 Then
n = Cells(Rows.Count, 1).End(xlUp).Row()
For i = 1 To n
used(Cells(i, 1).Value) = True
Next i
End If
For i = 1 To 100
If Not used(i) Then Available.Add i
Next i
Initialized = True
End Sub
Function NextRand()
'assumes that Initialize() has been called
Dim i As Long, num As Long
i = Application.WorksheetFunction.RandBetween(1, Available.Count)
num = Available.Item(i)
Available.Remove i
NextRand = num
End Function
Add a button, then in its event handler add the code to make it look something like:
(the actual name depends on the button and if it is an Active-X button, a forms button or just a shape)
Private Sub CommandButton1_Click()
If (Not Initialized) Or Range("A1").Value < 1 Then Initialize
Dim i As Long, n As Long
If Range("A1").Value < 1 Then
Range("A1").Value = NextRand()
Exit Sub
End If
n = 1 + Cells(Rows.Count, 1).End(xlUp).Row()
If n > 100 Then
Cells(n, 1).Value = CVErr(xlErrNA)
Else
Cells(n, 1).Value = NextRand()
End If
End Sub
Consider sorting a list of 100 random numbers and keeping their initial index. I have two buttons (or labels), one to initialize the list and the other to show the next random value
with code like this:
Const RandomCount As Long = 100
Private m_seq() As Variant ' Keep in memory the random numbers
Private m_current As Long ' Keep in memory the last shown number
Private Sub initializeLabel_Click()
Dim wk As Worksheet
Set wk = Worksheets.Add(Type:=xlWorksheet) 'add a worksheet
ReDim m_seq(1 To RandomCount, 1 To 2) 'Initialize a 2D array
Dim i As Long
For i = 1 To RandomCount
m_seq(i, 1) = i 'add values 1..100 to first column
m_seq(i, 2) = Rnd() 'add random numbers to second column
Next i
'Output the array into the new worksheet
wk.Range("A1").Resize(RandomCount, 2).Value2 = m_seq
' Sort the worksheet
wk.Range("A1").Resize(RandomCount, 2).Sort wk.Range("B1")
'Input the sorted values back into the array
m_seq = wk.Range("A1").Resize(RandomCount, 2).Value2
' Delete the worksheet quietly
Application.DisplayAlerts = False
wk.Range("A1").Resize(RandomCount, 2).ClearContents
wk.Delete
Application.DisplayAlerts = True
'Reset the UI
m_current = 0
[A1].ClearContents
End Sub
Private Sub randomLabel_Click()
m_current = m_current + 1
If m_current > RandomCount Then m_current = 1
[A1].Value2 = m_seq(m_current, 1)
End Sub
The values in the temporary worksheet look like this
and after the sort
of which the first column is used
I'm looking for code in VBA to generate all subsets of the items in a passed array.
Below is simple code to select all N choose 2 subsets of array size N.
Looking to augment this for N choose (N-1)... all the way down to N choose 1.
Option Base 1
Sub nchoose2()
iarray = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
n = UBound(iarray)
x = 1
t = 0
r = 0
Do While (n - x) >= 1
For i = 1 To (n - x)
Cells((i + t), 1) = iarray(x)
Cells((i + t), 2) = iarray(i + x)
Next i
x = x + 1
t = t + (n - (1 + r))
r = r + 1
Loop
End Sub
In addition to the Gray-code algorithm, you can also exploit the correspondence between subsets of an n-element set and binary vectors of length n. The following code illustrates this approach:
Sub AddOne(binaryVector As Variant)
'adds one to an array consisting of 0s and 1s
'thought of as a binary number in little-endian
'the vector is modified in place
'all 1's wraps around to all 0's
Dim bit As Long, carry As Long, i As Long, n As Long
carry = 1
n = UBound(binaryVector)
i = LBound(binaryVector)
Do While carry = 1 And i <= n
bit = (binaryVector(i) + carry) Mod 2
binaryVector(i) = bit
i = i + 1
carry = IIf(bit = 0, 1, 0)
Loop
End Sub
Function listSubsets(items As Variant) As Variant
'returns a variant array of collections
Dim lb As Long, ub As Long, i As Long, j As Long, numSets As Long
Dim vect As Variant 'binary vector
Dim subsets As Variant
lb = LBound(items)
ub = UBound(items)
ReDim vect(lb To ub)
numSets = 2 ^ (1 + ub - lb)
ReDim subsets(1 To numSets)
For i = 1 To numSets
Set subsets(i) = New Collection
For j = lb To ub
If vect(j) = 1 Then subsets(i).Add items(j)
Next j
AddOne vect
Next i
listSubsets = subsets
End Function
Function showCollection(c As Variant) As String
Dim v As Variant
Dim i As Long, n As Long
n = c.Count
If n = 0 Then
showCollection = "{}"
Exit Function
End If
ReDim v(1 To n)
For i = 1 To n
v(i) = c(i)
Next i
showCollection = "{" & Join(v, ", ") & "}"
End Function
Sub test()
Dim stooges As Variant
Dim stoogeSets As Variant
Dim i As Long
stooges = Array("Larry", "Curly", "Moe")
stoogeSets = listSubsets(stooges)
For i = LBound(stoogeSets) To UBound(stoogeSets)
Debug.Print showCollection(stoogeSets(i))
Next i
End Sub
Running the code results in the following output:
{}
{Larry}
{Curly}
{Larry, Curly}
{Moe}
{Larry, Moe}
{Curly, Moe}
{Larry, Curly, Moe}
I asked a similar question a while back (2005) and received this excellent code from John Coleman:
Sub MAIN()
Dim i As Long, st As String
Dim a(1 To 12) As Integer
Dim ary
For i = 1 To 12
a(i) = i
Next i
st = ListSubsets(a)
ary = Split(st, vbCrLf)
For i = LBound(ary) To UBound(ary)
Cells(i + 1, 1) = ary(i)
Next i
End Sub
Function ListSubsets(Items As Variant) As String
Dim CodeVector() As Integer
Dim i As Integer
Dim lower As Integer, upper As Integer
Dim SubList As String
Dim NewSub As String
Dim done As Boolean
Dim OddStep As Boolean
OddStep = True
lower = LBound(Items)
upper = UBound(Items)
ReDim CodeVector(lower To upper) 'it starts all 0
Do Until done
'Add a new subset according to current contents
'of CodeVector
NewSub = ""
For i = lower To upper
If CodeVector(i) = 1 Then
If NewSub = "" Then
NewSub = Items(i)
Else
NewSub = NewSub & ", " & Items(i)
End If
End If
Next i
If NewSub = "" Then NewSub = "{}" 'empty set
SubList = SubList & vbCrLf & NewSub
'now update code vector
If OddStep Then
'just flip first bit
CodeVector(lower) = 1 - CodeVector(lower)
Else
'first locate first 1
i = lower
Do While CodeVector(i) <> 1
i = i + 1
Loop
'done if i = upper:
If i = upper Then
done = True
Else
'if not done then flip the *next* bit:
i = i + 1
CodeVector(i) = 1 - CodeVector(i)
End If
End If
OddStep = Not OddStep 'toggles between even and odd steps
Loop
ListSubsets = SubList
End Function
The original question and answer:
John Coleman