Related
I have 2 arrays that I want to combine into a single array of all possible combinations. I then need to loop through all of the combinations and popular arguments for a function. My arrays are not equal in size, and my attempts so far have resulted in a combined array only having 1 pair of values. This is VBA in PowerPoint, not Excel, if that makes a difference to available syntax.
How can I go from this:
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
To this:
arrayCombo(0,0) = "Blue"
arrayCombo(0,1) = "XS"
arrayCombo(1,0) = "Blue"
arrayCombo(1,1) = "S"
...
arrayCombo(15,0) = "Red"
arrayCombo(15,1) = "XL"
And then use a loop to call each pair of values and populate argument values. This code just to illustrate the concept; it's certainly not legit. Pretty sure I need a nested loop here?
For i = 0 To UBound(arrayCombo(i))
nextSubToFire(color, size)
Next i
This is what I've got so far, but it only results in a single pair in my combined array. It's based on this question, but I think I'm either missing something or the sole answer there isn't quite correct. I've looked at other similar questions, but can't wrap my head around doing this with an array compiled in the code rather than the other examples all tailored to Excel.
Option Explicit
Dim arrayColorSize, arrayCombo
Sub CoreRoutine()
Dim arrayColor, arraySize
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
arrayColorSize = Array(arrayColor, arraySize)
arrayCombo = Array(0, 0)
DoCombinations (0)
Dim a As Integer
Dim b As Integer
'For loop comes next once I figure out how to populate the full arrayCombo
End Sub
Sub DoCombinations(ia)
Dim i
For i = 0 To UBound(arrayColorSize(ia)) ' for each item
arrayCombo(ia) = arrayColorSize(ia)(i) ' add this item
If ia = UBound(arrayColorSize) Then
Else
DoCombinations (ia + 1)
End If
Next i
End Sub
Using the Locals window, I see arrayCombo exists, but it only has 1 pair of values in it, which is the last set of pairing options. I see that arrayColorSize has the 2 array sets as I'd expect, so I suspect the DoCombinations sub is missing something.
Any guidance much appreciated!
One way of doing this is to combine the two 1D arrays into a 2D array with 2 columns (as in your example):
Private Function Combine1DArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant
If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then
Err.Raise 5, "Combine1DArrays", "Expected 1D arrays"
End If
'
Dim count1 As Long: count1 = UBound(arr1) - LBound(arr1) + 1
Dim count2 As Long: count2 = UBound(arr2) - LBound(arr2) + 1
Dim i As Long, j As Long, r As Long
Dim result() As Variant
'
ReDim result(0 To count1 * count2 - 1, 0 To 1)
r = 0
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
result(r, 0) = arr1(i)
result(r, 1) = arr2(j)
r = r + 1
Next j
Next i
Combine1DArrays = result
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
You can use it like this for example:
Sub CoreRoutine()
Dim arrayColorSize As Variant
Dim i As Long
Dim color As String
Dim size As String
'
arrayColorSize = Combine1DArrays(Array("Blue", "Green", "Red") _
, Array("XS", "S", "M", "L", "XL"))
For i = LBound(arrayColorSize, 1) To UBound(arrayColorSize, 1)
color = arrayColorSize(i, 0)
size = arrayColorSize(i, 1)
NextSubToFire color, size
Next i
End Sub
Sub NextSubToFire(ByVal color As String, ByVal size As String)
Debug.Print color, size
End Sub
I am running into a problem, Although very simple but stuck up, I have a string from a cell, I split the string into characters using Mid function and store it into an array. Now I want to print the array to a different range but I am unable to do it. I've tried many different codes but all in vein.
please help.
My Code is as
Option Base 1
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k, l, m As Integer
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Range("C1:C12") = NewArray
End Function
You have to transpose the array to put values in a column.
Option Explicit
Option Base 1
Sub test()
Call Takseer("ABCDEFGHUIJKL")
End Sub
Function Takseer(StrEx As String)
Dim NewArray() As Variant, s As String, m As Integer, k As Integer
s = Replace(StrEx, " ", "")
m = Len(s)
If m = 0 Then Exit Function
ReDim NewArray(m)
For k = 1 To m
NewArray(k) = Mid(s, k, 1)
Next k
' in a row
Sheet1.Range("C1").Resize(1, m) = NewArray
' in a column
Sheet1.Range("C2").Resize(m, 1) = WorksheetFunction.Transpose(NewArray)
End Function
Assuming the array you obtain is "Apple", "Orange", "Grape", "Durian", in order to write into worksheet you cannot directly call the variant. One way to write the value is to first get the length of your variant, then write the value from array starting from index 0, here is how I perform you expectation:
Sub test1()
Dim NewArray() As Variant
Dim i As Long, arrayLoop As Long
Dim StrEx As String
Dim k, l, m As Integer
StrEx = "Hello today is my first day"
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 0 To m - 1
ReDim Preserve NewArray(m - 1)
NewArray(k) = Mid(StrEx, k + 1, 1)
Next k
i = UBound(NewArray) - LBound(NewArray) + 1
For arrayLoop = 0 To i - 1
Sheet1.Range("A" & arrayLoop + 1).Value = NewArray(arrayLoop)
Next
End Sub
Please take note when perform array loop, you have to minus the length by 1, else it will be out of range, the reason is that array index always start from zero based (0)
And check the post for how to obtain length of array Get length of array?
Some problems with your function:
A formula returns a value. It is not used to alter other properties/cells of a worksheet.
Hence you should set your results to the function; not try to write to a range
Dim k, l, m As Integer only declares m as Integer, k and l are unspecified so they will be declared as a variant.
The constructed array will be horizontal. If you want the results vertical, you need to Transpose it, or create a 2D array initially.
Option Base 1 is unnecessary since you explicitly declare the lower bound
Assuming you want to use this function on a worksheet, TestIt sets things up.
Note2: The formula on the worksheet assumes you have Excel with dynamic arrays. If you have an earlier version of Excel, you will need to have a different worksheet formula
See your modifed function and TestIt:
Modified with Transpose added to worksheet formula
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Transpose(Takseer(A1))"
End Sub
Modified to create 2d vertical array
can't really use redim preserve on this array. And I prefer to avoid it anyway because of the overhead
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant, col As Collection
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
Set col = New Collection
For k = 1 To m
col.Add Mid(StrEx, k, 1)
Next k
ReDim NewArray(1 To col.Count, 1 To 1)
For k = 1 To col.Count
NewArray(k, 1) = col(k)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Takseer(A1)"
End Sub
Note:
TestIt is merely to test the function. You should enter the appropriate formula yourself, either manually or programmatically, into the destination range.
If you do not have dynamic arrays, then you would need to enter an array formula into the destination range; or a formula using the INDEX function to return each element of the array.
In TestIt, you might change the line that puts the formula onto the worksheet to Range(Cells(1, 3), Cells(Len([a1]), 3)).FormulaArray = "=Takseer(a1)", but, again, it is anticipated that you would be entering the correct formula onto your worksheet manually or programmatically anyway.
I have a number (say 5) which I would first like to convert to binary (101) and then split into an array of bits {1,0,1} or Booleans {True,False,True} in VBA
Is there a way to do this without looping?
I can convert to Binary without looping in my code with the worksheet formula as follows
myBinaryNum = [DEC2BIN(myDecInteger,[places])]
But I've been told that worksheet functions are very inefficient, and this one is particularly limited.
I'm not sure how to split into an array without looping through the digits with MID. Is there anything like strConv for numbers?
You could first convert the value to a "01" string with WorksheetFunction.Dec2Bin.
Then replace each "0","1" with the code 0 or 1 and cast the result to a Byte array :
Public Function ToBitArray(ByVal value As Long) As Byte()
Dim str As String
str = WorksheetFunction.Dec2Bin(value) ' "101"
str = Replace(Replace(str, "0", ChrW(0)), "1", ChrW(1)) ' "\u0001\u0000\u0001"
ToBitArray = StrConv(str, vbFromUnicode) ' [1, 0, 1]
End Function
But Dec2Bin is limited to 511 and working with strings is rather expensive. So if your goal is to get the best performance, then you should use a loop to read each bit:
Public Function ToBitArray(ByVal value As Long) As Byte()
Dim arr(0 To 31) As Byte, i As Long
i = 32&
Do While value
i = i - 1
arr(i) = value And 1
value = value \ 2
Loop
ToBitArray = MidB(arr, i + 1) ' trim leading zeros
End Function
I found this neat code on another question here at SO. Basically, you can be sure your string is ASCII due to the fact it's 1's and 0's.
What you do is you use
Dim my_string As String
my_string = CStr("your binary number")
To turn your binary number into a string
And then
Dim buff() As String
buff = Split(StrConv(my_string, vbUnicode), Chr$(0))
ReDim Preserve buff(UBound(buff) - 1
To split that string into an array where buff is your array
I think you've probably got everything you need above from other answers, but if you want a simple function that takes the decimal and returns the array..
Function dec_to_binary_array(decNum As Integer)
Dim arr() As String, NumAsString As String
NumAsString = Application.Dec2Bin(decNum)
arr = Split(StrConv(NumAsString, vbUnicode), vbNullChar)
ReDim Preserve arr(UBound(arr) - 1)
dec_to_binary_array = arr
End Function
Invoking Application.Dec2Bin(n) isn't realy expensive, it only costs a late bound call. Use the function below to transform any integer into an arrays of bits:
Function Bits(n as long)
Dim s As String: s = Application.Dec2Bin(n)
Dim ar: ar = Split(StrConv(s, vbUnicode), vbNullChar)
Bits = ar
End Function
p.s.: s will only contain 0 and 1 which are ASCII characters, so the split technique is perfectly valid.
Function d2bin(dec As Integer, bits As Integer) As Integer()
Dim maxVal As Integer
maxVal = 2 ^ (bits)-1
If dec > maxVal Then Exit Function
Dim i As Integer
Dim result() As Integer
ReDim result(0 To bits - 1)
For i = bits - 1 To 0 Step -1
result(bits - i - 1) = -(dec > (2 ^ (i) - 1))
If result(bits - i - 1) Then dec = dec - (2 ^ i)
Next i
d2bin = result
End Function
Please check this code if this is what you need:
You can replace the the digit 5 by any cell value reference, this is just and example:
Sub dectobinary()
Dim BinaryString As String
BinaryString = "5"
tempval = Dec2Bin(BinaryString)
MsgBox tempval
End Sub
Function Dec2Bin(ByVal DecimalIn As Variant) As String
Dec2Bin = ""
DecimalIn = Int(CDec(DecimalIn))
Do While DecimalIn <> 0
Dec2BinTemp = Format$(DecimalIn - 2 * Int(DecimalIn / 2))
If Dec2BinTemp = "1" Then
Dec2Bin = "True" & "," & Dec2Bin
Else
Dec2Bin = "False" & "," & Dec2Bin
End If
DecimalIn = Int(DecimalIn / 2)
Loop
End Function
Just change lngNumber value to your desired number
Public Sub sChangeNumberToBinaryArray()
Dim strBinaryNumber As String
Dim strBinaryArray() As String
Dim lngNumber As Long
lngNumber = 5
strBinaryNumber = DecToBin(lngNumber)
strBinaryArray() = Split(strBinaryNumber, "|")
End Sub
Function DecToBin(ByVal varDecimalIn As Variant) As String
Dim lngCounter As Long
DecToBin = ""
varDecimalIn = Int(CDec(varDecimalIn))
lngCounter = 1
Do While varDecimalIn <> 0
If lngCounter = 1 Then
DecToBin = Format$(varDecimalIn - 2 * Int(varDecimalIn / 2)) & DecToBin
lngCounter = lngCounter + 1
Else
DecToBin = Format$(varDecimalIn - 2 * Int(varDecimalIn / 2)) & "|" & DecToBin
lngCounter = lngCounter + 1
End If
varDecimalIn = Int(varDecimalIn / 2)
Loop
End Function
Final final results:
I was wondering whether the results below changed if the string was longer. I ran exactly the same tests on the same computer, except each cell had a random string of 34 characters rather than four. These were the results:
Comintern (Regexp): 136.1 ms
brettdj (Regexp): 139.9 ms
Slai (Regexp): 158.4 ms
*Original Regex: 161.0 ms*
Comintern (AN): 170.1 ms
Comintern (Hash): 183.6 ms
ThunderFrame: 232.9 ms
*Original replace: 372.9 ms*
*Original InStr: 478.1 ms*
CallumDA33: 1218.1 ms
This really shows the speed of the Regex - all the solutions utilising Regex.replace are significantly faster, with the best being Comintern's implementation.
In summary, if the strings are long, use arrays, if they are short, use the clipboard. If unsure, the optimal result is to use arrays, but this may sacrifice a little performance on short strings.
Final results:
Thanks very much for all of your suggestions, clearly I still have a lot to learn. I was thinking about this all yesterday, so I decided to rerun everything at home. Here are the final results, based on applying each of these to 30,000 four character strings.
My computer at home is an Intel i7 # 3.6 GHz, 8GB RAM, 64-bit Windows 10 and Excel 2016. Similar conditions to before in that I have processes running in the background, but I'm not actively doing anything throughout the tests.
Original replace: 97.67 ms
Original InStr: 106.54 ms
Original Regex: 113.46 ms
ThunderFrame: 82.21 ms
Comintern (AN): 96.98 ms
Comintern (OR): 81.87 ms
Comintern (Hash): 101.18 ms
brettdj: 81.66 ms
CallumDA33: 201.64 ms
Slai: 68.38 ms
I've therefore accepted Slai's answer as it is clearly the fastest for general implementation, but I'll rerun them all at work against the actual data to check this still works.
Original post:
I have an array in Excel that is a list of part numbers. I need to turn every member of the array alphanumeric, for example
ABC123-001 -> ABC123001
ABC123/001 -> ABC123001
ABC123001 -> ABC123001
What is the fastest way of doing this?
For context, our part numbers can come in different forms, so I'm writing a function that finds the best match within a given range. At the moment, the part of the function that makes everything alphanumeric takes about 50ms to run, whereas the rest of the function takes around 30ms in total. I also can't avoid using Excel.
I've done some work myself (see answer below), but the main issue is that I have to loop through every element of the array one-by-one - could there be a better way? I've also never run tests before, so any feedback on improving them would be much appreciated.
Here is what I've tried so far.
I'm using MicroTimer and my computer has an Intel i5 #2.5GHz, 4GB of RAM, 64-bit Windows 7. I've got processes running in the background, but I'm not actively doing anything else whilst these are run.
I created 30,000 lines of random symbols using this code:
=CHAR(RANDBETWEEN(1,60))&CHAR(RANDBETWEEN(48,57))&CHAR(RANDBETWEEN(37,140))&CHAR(RANDBETWEEN(37,140))
(note how we stop the first character at 60 because '=' is char(61) and we want to avoid Excel interpreting this as a formula. Also we force the second character to be a number so we can guarantee at least one alphanumeric character in there.)
1. Using a loop based on cases. Average time: 175ms
Using the function in this post, we load the range into an array, apply the function to each element of the array and paste it back. Code:
Function AlphaNumericOnly(strSource As Variant) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
Sub Replace()
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("Replace")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim arr As Variant
arr = inputRng
Dim i As Integer
For i = LBound(arr) To UBound(arr)
arr(i, 1) = AlphaNumericOnly(arr(i, 1))
Next i
outputRng = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
2. Using InStr() to check each character. Average time: 201ms
Define a string of valid values. Check one-by-one if the valid values appear in the array elements:
Sub InStr()
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("InStr")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim arr As Variant
arr = inputRng
Dim validValues As String
validValues = "01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 'put numbers and capitals at the start as they are more likely'
Dim i As Integer, j As Integer
Dim result As String
For i = LBound(arr) To UBound(arr)
result = vbNullString
For j = 1 To Len(arr(i, 1))
If InStr(validValues, Mid(arr(i, 1), j, 1)) <> 0 Then
result = result & Mid(arr(i, 1), j, 1)
End If
Next j
arr(i, 1) = result
Next i
outputRng = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
3. Using regex.Replace on the array. Time: 171ms
Define a regex and use this to replace each element of the array.
Sub Regex()
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("Regex")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim arr As Variant
arr = inputRng
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.ignorecase = True
.Pattern = "[^\w]"
End With
Dim i As Integer
For i = LBound(arr) To UBound(arr)
arr(i, 1) = objRegex.Replace(arr(i, 1), vbNullString)
Next i
outputRng = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
Edit:
#ThunderFrame - our part numbers generally come in the following formats:
All numbers (e.g. 32523452)
Mix of letters and numbers (e.g. AB324K234 or 123H45645)
Mix of letters and numbers, each linked by a non-alphanumeric character (e.g. ABC001-001, ABC001/001, 123/4557-121)
I have thought about using regex.test on each string before launching into the replacement, but I'm not sure if this will just copy the string to then test it, in which case I may as well just make the replacement to start with.
#Slai - thanks for the link - I will look into that in more detail
Not sure if this would be faster because it depends on too many factors, but might be worth testing. Instead of Regex.Replace each value separately, you can get the copied Range text from the clipboard and replace all values at once. Note that \w matches underscore and Unicode letters too, so being more specific in the regular expression can make it faster.
'[a1:b30000] = [{"ABC123-009",""}]: Dim t As Double: t = Timer ' used for testing
Dim r As Range, s As String
Set r = ThisWorkbook.Worksheets("Data").UsedRange.Resize(, 1) ' Data!A1:A30000
With New MSForms.DataObject ' needs reference to "Microsoft Forms 2.0 Object Library" or use a bit slower late binding - With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
r.Copy
.GetFromClipboard
Application.CutCopyMode = False
s = .GetText
.Clear ' optional - clear the clipboard if using Range.PasteSpecial instead of Worksheet.PasteSpecial "Text"
With New RegExp ' needs reference to "Microsoft VBScript Regular Expressions 5.5" or use a bit slower late binding - With CreateObject("VBScript.RegExp")
.Global = True
'.IgnoreCase = False ' .IgnoreCase is False by default
.Pattern = "[^0-9A-Za-z\r\n]+" ' because "[^\w\r\n]+" also matches _ and Unicode letters
s = .Replace(s, vbNullString)
End With
.SetText s
.PutInClipboard
End With
' about 70% of the time is spent here in pasting the data
r(, 2).PasteSpecial 'xlPasteValues ' paste the text from clipboard in B1
'Debug.Print Timer - t
I expect this to be slower for less values because of the clipboard overhead, and maybe slower for a lot more values because of the memory needed.
Disabling events didn't seem to make difference in my tests, but might be worth trying.
Note that there is a tiny chance of another application using the clipboard while the macro is using it.
If early binding causes issues from running the same compiled macro on different machines, you can search for macro decompiler or remove the references and switch to late binding.
tl;dr - Regular expressions destroy VBA implementations. If this were a code challenge, #brettj or #Slai should win it.
There are a bunch of tricks to make your AlphaNumericOnly faster.
First, you can get rid of the vast majority of the function calls by treating it as a byte array instead of a string. That removes all of the calls to Mid$ and Asc. Although these are incredibly fast functions, they still add the overhead pushing onto and popping off of the call stack. That adds up over a couple hundred thousand iterations.
The second optimization is to not use Case x To y syntax if you can avoid it. The reason has to do with how it compiles - it doesn't compile to a test like Case = Condition >= x And Condition <= y, it actually creates a loop with an early exit condition like this:
Case = False
For i = x To y
If Condition = i Then
Case = True
End If
Next
Again, not a huge performance hit, but it adds up. The third optimization is to order your tests in a way that makes them sort circuit on the most likely hits in your data set. I tailored my examples below for primarily letters, with most of them upper case. You may do better with different ordering. Put it all together and you get something that looks like this:
Public Function ByteAlphaNumeric(source As Variant) As String
Dim chars() As Byte
Dim outVal() As Byte
chars = CStr(source) 'Load the array up.
Dim bound As Long
bound = UBound(chars) 'Size the outbound array.
ReDim outVal(bound)
Dim i As Long, pos As Long
For i = 0 To bound Step 2 'Wide characters, only care about the ASCII range.
Dim temp As Byte
temp = chars(i) 'Pointer math isn't free. Cache it.
Select Case True 'Order is important here.
Case temp > 64 And temp < 91
outVal(pos) = temp
pos = pos + 2 'Advance the output pointer.
Case temp < 48
Case temp > 122
Case temp > 96
outVal(pos) = temp
pos = pos + 2
Case temp < 58
outVal(pos) = temp
pos = pos + 2
End Select
Next
'This is likely the most expensive operation.
ReDim Preserve outVal(pos) 'Trim the output array.
ByteAlphaNumeric = outVal
End Function
How does it do? Pretty well:
Public Sub Benchmark()
Dim starting As Single, i As Long, dummy As String, sample As Variant
sample = GetRandomString
starting = Timer
For i = 1 To 1000000
dummy = AlphaNumericOnlyOP(sample)
Next i
Debug.Print "OP's AlphaNumericOnly: ", Timer - starting
starting = Timer
For i = 1 To 1000000
dummy = AlphaNumericOnlyThunderframe(sample)
Next i
Debug.Print "ThunderFrame's AlphaNumericOnly: ", Timer - starting
starting = Timer
For i = 1 To 1000000
dummy = AlphaNumeric(sample)
Next i
Debug.Print "CallumDA33's AlphaNumeric: ", Timer - starting
starting = Timer
For i = 1 To 1000000
dummy = ByteAlphaNumeric(sample)
Next i
Debug.Print "ByteAlphaNumeric: ", Timer - starting
Dim cast As String
cast = CStr(sample)
starting = Timer
For i = 1 To 1000000
dummy = ByteAlphaNumericString(cast)
Next i
Debug.Print "ByteAlphaNumericString: ", Timer - starting
Set stripper = Nothing
starting = Timer
For i = 1 To 1000000
dummy = OptimizedRegex(sample)
Next i
Debug.Print "OptimizedRegex: ", Timer - starting
End Sub
Private Function GetRandomString() As Variant
Dim chars(30) As Byte, i As Long
Randomize
For i = 0 To 30 Step 2
chars(i) = Int(96 * Rnd + 32)
Next i
Dim temp As String
temp = chars
GetRandomString = CVar(temp)
End Function
Results with a 15 character random String:
OP`s AlphaNumericOnly: 6.565918
ThunderFrame`s AlphaNumericOnly: 3.617188
CallumDA33`s AlphaNumeric: 23.518070
ByteAlphaNumeric: 2.354980
Note, I omitted submissions that weren't trivial to convert to functions. You may notice 2 additional test - the ByteAlphaNumericString is exactly the same as the ByteAlphaNumeric function, but it takes a String as input instead of a Variant and gets rid of the cast. That's not trivial:
ByteAlphaNumericString: 2.226074
And finally, the elusive OptimizedRegex function (basically #brettj's code in function form for comparison timing):
Private stripper As RegExp 'Module level
Function OptimizedRegex(strSource As Variant) As String
If stripper Is Nothing Then
Set stripper = New RegExp
With stripper
.Global = True
.Pattern = "[^0-9A-Za-z]"
End With
End If
OptimizedRegex = stripper.Replace(strSource, vbNullString)
End Function
OptimizedRegex: 1.094727
EDIT: Bonus implementation!
It occurred to me that a hash table lookup might be faster than a Select Case structure, so I built one with using a Scripting.Dictionary:
Private hash As Scripting.Dictionary 'Module level
Function HashLookups(source As Variant) As String
Dim chars() As Byte
Dim outVal() As Byte
chars = CStr(source)
Dim bound As Long
bound = UBound(chars)
ReDim outVal(bound)
Dim i As Long, pos As Long
With hash
For i = 0 To bound Step 2
Dim temp As Byte
temp = chars(i)
If .Exists(temp) Then
outVal(pos) = temp
pos = pos + 2
End If
Next
End With
ReDim Preserve outVal(pos)
HashLookups = outVal
End Function
Private Sub LoadHashTable()
Set hash = New Scripting.Dictionary
Dim i As Long
For i = 48 To 57
hash.Add i, vbNull
Next
For i = 65 To 90
hash.Add i, vbNull
Next
For i = 97 To 122
hash.Add i, vbNull
Next
End Sub
'Test code:
starting = Timer
LoadHashTable
For i = 1 To 1000000
dummy = HashLookups(sample)
Next i
Debug.Print "HashLookups: ", Timer - starting
It turned out to be not too shabby:
HashLookups: 1.655273
Final Version
Woke up and thought I'd try a vector lookup instead of a hash lookup (just fill a byte array of values to keep and use that for tests). This seems reasonable in that it's only a 256 element array - basically a truth table:
Private lookup(255) As Boolean 'Module level
Function VectorLookup(source As Variant) As String
Dim chars() As Byte
Dim outVal() As Byte
chars = CStr(source)
Dim bound As Long
bound = UBound(chars)
ReDim outVal(bound)
Dim i As Long, pos As Long
For i = 0 To bound Step 2
Dim temp As Byte
temp = chars(i)
If lookup(temp) Then
outVal(pos) = temp
pos = pos + 2
End If
Next
ReDim Preserve outVal(pos)
VectorLookup = outVal
End Function
Private Sub GenerateTable()
Dim i As Long
For i = 48 To 57
lookup(i) = True
Next
For i = 65 To 90
lookup(i) = True
Next
For i = 97 To 122
lookup(i) = True
Next
End Sub
Assuming that the lookup table is only generated once, it's clocking in somewhere around 10-15% faster than any other pure VBA method above.
Credit to ThunderFrame (I'm a sucker for a LHS Mid$) but I got better performance from the early bound RegExp with additional small tweaks:
Use Value2 rather than Value
Declare your loop with long not integer
.ignorecase = True is redundant
code
Sub Replace2()
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("Replace")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim arr As Variant
Dim objRegex As VBScript_RegExp_55.RegExp
Dim i As Long
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.Pattern = "[^\w]"
End With
arr = inputRng.Value2
For i = LBound(arr) To UBound(arr)
arr(i, 1) = objRegex.Replace(arr(i, 1), vbNullString)
Next i
outputRng.Value2 = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
If you change the function in your first, and currently best performing routine, to the following, you'll get a performance improvement of at least 40-50% depending on your data:
Function AlphaNumericOnly(strSource As Variant) As String
Dim i As Long
Dim charCount As Long
Dim strResult As String
Dim char As String
strResult = Space$(Len(strSource))
For i = 1 To Len(strSource)
char = Mid$(strSource, i, 1)
Select Case Asc(char)
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
charCount = charCount + 1
Mid$(strResult, charCount, 1) = char
End Select
Next
AlphaNumericOnly = Left$(strResult, charCount)
End Function
I used a few optimizations, but chiefly, you were re-assigning the strResult multiple times in a loop, which is very expensive, and even more expensive when your strings are longer (and the loop runs more times). Much better to use Mid$.
And, using the $-suffixed functions are optimized for strings, so you'll get better performance there too
Optimizing the RegEx version
Your Regex approach has reasonable performance, but you're using late-bound CreateObject, which would be much faster as an early-bound, strongly typed reference.
Furthermore, your Regex pattern and options are the same every time, you could declare the regex object as variable, and only create it if it doesn't already exist, then re-use the existing regex each time.
It is not true that Regex has to be the winner. My second solution below is faster than even early-bound Regex! And my first solution is as fast as late-bound Regex. BOTH ARE NATIVE VBA ONLY.
Interesting question. The Original InStr method should be much faster than the results shown in the OP's question.
Its poor performance is due to string concatenation, which VBA is not good at. The longer the strings the worse it gets.
My version of the InStr method below does not use concatenation at all. It is many times faster than the original. In fact, its speed of execution matches late-bound Regex. This InStr version is completely native to VBA and very, very fast. And the longer the source strings, the faster it gets, relative to concatenation.
This method also gains a few ticks of performance by utilizing the ($) version of string functions instead of the variant version. InStrB is slightly faster than InStr. And using temporary string variables t and arx saves a good chunk of time as well.
Sub InStr_ExcelHero()
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("InStr")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim i&, j&, p&, max&, arx$, t$, res$, arr
arr = inputRng
max = Len(arr(1, 1))
Dim validVals$: validVals = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
For i = LBound(arr) To UBound(arr)
p = 0
arx = arr(i, 1)
res = Space$(max)
For j = 1 To max
t = Mid$(arx, j, 1)
If InStrB(validVals, t) Then
p = p + 1
Mid$(res, p, 1) = t
End If
Next
arr(i, 1) = Left$(res, p)
Next
outputRng = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
And the ArrayLookup version below is more than twice as fast as InStr_ExcelHero().
In fact, the method below is actually faster than early-bound Regex!
This is native VBA. No dependencies. Faster than Regex. The following method is likely the quickest way to turn every element of an array to alphanumeric... when directed from VBA... other than a custom c++ dll:
Sub ArrayLookup_ExcelHero()
Const VALS$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Dim inputSh As Worksheet
Dim inputRng As Range
Set inputSh = Sheets("Data")
Set inputRng = inputSh.Range("A1:A30000")
Dim outputSh As Worksheet
Dim outputRng As Range
Set outputSh = Sheets("InStr")
Set outputRng = outputSh.Range("A1:A30000")
Dim time1 As Double, time2 As Double
time1 = MicroTimer
Dim i&, j&, p&, max&, t&, arx() As Byte, res() As Byte, arr
arr = inputRng
max = Len(arr(1, 1))
Dim Keep&(0 To 255)
For i = 1 To Len(VALS)
Keep(Asc(Mid$(VALS, i, 1))) = 1
Next
For i = LBound(arr) To UBound(arr)
p = 0
ReDim res(0 To max)
arx = StrConv(arr(i, 1), vbFromUnicode)
For j = 0 To max - 1
t = arx(j)
If Keep(t) Then
res(p) = t
p = p + 1
End If
Next
arr(i, 1) = StrConv(res, vbUnicode)
Next
outputRng = arr
time2 = MicroTimer
Debug.Print (time2 - time1) * 1000
End Sub
I'll throw this out there, if nothing else to see how it performs. I'm sure it could be tidied up a bit too.
My hope is that the method for testing if a character is a letter turn out faster. I'm sure testing for a number could be done a bit quicker though.
Function AlphaNumeric(s As String) As String
Dim char As String, tempStr As String
Dim i As Integer
Dim t As Variant
For i = 1 To Len(s)
char = Mid(s, i, 1)
If IsLetter(char) Or IsNumber(char) Then
tempStr = tempStr & char
End If
Next i
AlphaNumeric = tempStr
End Function
Private Function IsLetter(s As String) As Boolean
If UCase(s) = s And LCase(s) = s Then
IsLetter = False
Else:
IsLetter = True
End If
End Function
Private Function IsNumber(s As String)
On Error GoTo 1
s = s * 1
IsNumber = True
Exit Function
1:
IsNumber = False
End Function
I think this is my first question in this forum, so excuse me if I miss following some rules. I am trying to write a VBA algorithm to compute the Shapley-Shubik index. This index requires to compute all the permutations of a sequence of numbers (which represent the votes in a parliament, congress, etc.). After some thorough research I understood that one must use a recursive algorithm to perform such thing.
My idea is to create a matrix in vba where each element is stored separately, and each row contains a different permutation. That is the only way I can subsequently perform computations and retrieve the correct label values needed to compute such index.
The problem is I cannot understand how to revert back to the previous levels once I reach the last level of recursion.
(EDIT) Eventually, I was able to come up with a solution. I am posting the results below, since I have seen that it has been asked for. I should warn though, this is a very inefficient code, and it does not work with more than 7 players. The reason for this is because vba is not able to deal with the extremely big matrix created by this code, so the program just crashes with an overflow error.
However, in have not been particularly smart in writing this code, this means it should be pretty easy to modify the code in order to make it work for a bigger number of players. Basically, instead of using the permutation function to create a matrix, one just needs to compute the pivotal player in each specific permutation, then use an array to "store" the frequencies. Unfortunately, I did not have time to modify the code, as I am currently working on other projects, though somewhat related, using Matlab instead.
Here it is the function I have assembled:
Public Function ShapleyShubik( _
Votes As Range, _
Coalitions As Range, _
Candidate As String, _
Threshold As Double) As Double
'
'------------------------------------------------------
' by Sim1
' This function computes the Shapley-Shubik Power Index
' For a specified coalition among the available ones
'------------------------------------------------------
'
Dim Labels() As String
Dim Powers() As Double
Dim Interval As Variant
Dim MatLabels() As String
Dim MatPowers() As Integer
Dim Calc() As String
Dim Total As Integer
Dim ii As Integer
'Convert Labels Range
Interval = ToArray(Coalitions)
ReDim Labels(1 To UBound(Interval)) As String
For ii = 1 To UBound(Interval)
Labels(ii) = CStr(Interval(ii))
Next
'Convert Powers Range
Interval = ToArray(Votes)
ReDim Powers(1 To UBound(Interval)) As Double
For ii = 1 To UBound(Interval)
Powers(ii) = CInt(Interval(ii))
Next
SShubCalc Powers, Labels, Calc, Threshold, Total
'Compute Index
ShapleyShubik = (UBound(Filter(Calc, Candidate, True)) + 1) / Total
End Function
Private Function SShubCalc( _
ByRef Powers() As Double, _
ByRef Labels() As String, _
ByRef Pivotal() As String, _
ByVal bar As Double, _
ByRef Righe As Integer) As Boolean
On Error GoTo Error_line
Dim Colonne As Integer
Dim MatNum() As Double
Dim MatStr() As String
Dim Threshold As Integer
Dim Somma() As Double
Dim perfsum() As Boolean
Dim PivPos() As Integer
Dim Addend() As Double
Dim v() As Variant
' Define Size Variables
Colonne = UBound(Powers)
Righe = Factorial(Colonne)
'Generate Matrix of Permutations
MatrPerm Powers, MatNum, Labels, MatStr
'Provide Vector Sums and Check Threshold
With Application.WorksheetFunction
Threshold = .Sum(.index(MatNum, 1))
End With
'Control for unanimity
If (Threshold * bar) < (Threshold - 1) Then
Threshold = Round(Threshold * bar, 0) + 1
End If
'Initialize Arrays
ReDim perfsum(1 To Righe)
ReDim PivPos(1 To Righe)
ReDim Pivotal(1 To Righe)
For ii = 1 To Colonne
'First Iteration
If ii = 1 Then
v = Application.WorksheetFunction.index(MatNum, 0, ii)
ToDoubleArray Somma, v
Else:
v = Application.WorksheetFunction.index(MatNum, 0, (ii))
ToDoubleArray Addend, v
SumVector Somma, Somma, Addend
End If
For j = 1 To Righe
If Somma(j) >= Threshold And perfsum(j) = False Then
PivPos(j) = ii
perfsum(j) = True
End If
Next j
Next ii
'Transfer PivoPos to Labels
For ii = 1 To Righe
Pivotal(ii) = MatStr(ii, PivPos(ii))
Next ii
SShubCalc = True
Exit Function
Error_line:
SShubCalc = False
End Function
Private Function nextPerm(s As String)
' inspired by http://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte
L = Len(s)
If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
nextPerm = ""
Exit Function
End If
' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
c(ii) = Asc(Mid(s, ii, 1))
Next ii
' find the largest "tail":
For ii = L - 1 To 1 Step -1
If c(ii) < c(ii + 1) Then Exit For
Next ii
' if we complete the loop without break, ii will be zero
If ii = 0 Then
nextPerm = "**done**"
Exit Function
End If
' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
If c(jj) > c(ii) Then
' swap elements
temp = c(jj)
c(jj) = c(ii)
c(ii) = temp
Exit For
End If
Next jj
' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
nextPerm = nextPerm & Chr(c(jj))
Next jj
'Debug.Print nextPerm
End Function
Private Function Factorial(dblNumber As Integer) As Integer
Dim dblCtr As Double
Dim dblResult As Double
dblResult = 1 'initializes variable
For dblCtr = 1 To dblNumber
dblResult = dblResult * dblCtr
Next dblCtr
Factorial = dblResult
End Function
Private Function SumVector(ByRef Result() As Double, ByRef Vec1() As Double, ByRef Vec2() As Double)
Dim temp As Integer
Dim tempuno As Integer
Dim ii As Integer
If LBound(Vec1) = 0 Then
temp = UBound(Vec2)
ReDim Preserve Vec1(1 To (temp + 1))
End If
If LBound(Vec2) = 0 Then
tempuno = UBound(Vec2)
ReDim Preserve Vec2(1 To (temp + 1))
End If
If temp <> tempuno Then
Exit Function
End If
ReDim Preserve Result(1 To UBound(Vec1))
'Debug.Print Vec1(1, 1)
For ii = 1 To UBound(Vec1)
Result(ii) = Vec1(ii) + Vec2(ii)
Next ii
End Function
Private Function ToDoubleArray( _
ByRef DoubleArray() As Double, _
ByRef VariantArray() As Variant)
If LBound(VariantArray) = 0 Then
ReDim Preserve VariantArray(1 To (UBound(VariantArray) + 1))
End If
ReDim DoubleArray(1 To UBound(VariantArray))
For ii = 1 To UBound(VariantArray)
DoubleArray(ii) = VariantArray(ii, 1)
Next ii
End Function
Private Function MatrPermStr( _
ByRef VecInput() As String, _
ByRef MatOutput() As String)
Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer
' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)
ReDim MatOutput(1 To Righe, 1 To Colonne) As String
'Start With an Empty Sequence
Sequence = ""
'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii
'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
Next ii
Next j
End Function
Private Function MatrPerm( _
ByRef VecInput() As Double, _
ByRef MatOutput() As Double, _
ByRef VecInputStr() As String, _
ByRef MatOutputStr() As String)
Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer
Dim t As Integer
' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)
ReDim MatOutput(1 To Righe, 1 To Colonne)
ReDim MatOutputStr(1 To Righe, 1 To Colonne)
'Start With an Empty Sequence
Sequence = ""
'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii
'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
MatOutputStr(j, ii) = VecInputStr(Mid(StrPerm, ii, 1))
Next ii
Next j
End Function
Private Function ToArray(ByRef someRange As Range) As Variant
Dim someValues As Variant
With someRange
If .Cells.Count = 1 Then
ReDim someValues(1 To 1)
someValues(1) = someRange.Value
ElseIf .Rows.Count = 1 Then
someValues = Application.Transpose(Application.Transpose(someRange.Value))
ElseIf .Columns.Count = 1 Then
someValues = Application.Transpose(someRange.Value)
Else
MsgBox "someRange is mutil-dimensional"
End If
End With
ToArray = someValues
End Function
Private Sub DescribeShapShub()
Dim FuncName As String
Dim FuncDesc As String
Dim Category As String
Dim ArgDesc(1 To 4) As String
FuncName = "SHAPLEYSHUBIK"
FuncDesc = "Returns Shapley-Shubik power index for a given player, given the other players' votes"
Category = 3 'Math category
ArgDesc(1) = "Range containing the player's votes (Only selected votes will be considered in the computation)"
ArgDesc(2) = "Range containing the player's names (must have the same length as ""Votes"")"
ArgDesc(3) = "Cell or String containing the player for which to compute the index"
ArgDesc(4) = "Cell or Number containing the voting threshold (e.g. 0.5 for 50%)"
Application.MacroOptions _
Macro:=FuncName, _
Description:=FuncDesc, _
Category:=Category, _
ArgumentDescriptions:=ArgDesc
End Sub
Sorry if some variables are in Italian. Also, some parts of the code have been retrieved here and there in some specialised forums, so I take no credit for the specific commands, just for the assembling :)
One last request: if anyone is able to improve this code, please share it so everybody can use it.
I am not going to answer your question exactly; but I would like to offer you a nice little function that will help solve your bigger problem. This function generates the "next" permutation of a string - where the string can contain numbers or letters, and "next" is in a lexicographical sense (see [this discussion](Generating permutations lazily
)).
What can you do with it? Well, when you want to compute anything "over all possible permutations", having a function that gives you "just the next permutation" will keep your code readable (it takes away an awful lot of housekeeping!). You can then simply say (this is pseudocode):
// initialize stuff
firstPerm = "1234"
np = nextPerm(firstPerm)
// loop over all permutations
while not np equals "done"
// update calculations on np
np = nextPerm(np)
wend
// report your results
Here is the function. It seemed to behave itself for me - even when I have multiple identical characters in the string, or a mixture of letters and numbers. Note that it treats A and a as distinct... Also note that it returns the string "done" when it is done. Obviously, if you happen to pass it the string "doen" as input, it will return "done" although it isn't done... Try to avoid that!
Function nextPerm(s As String)
' inspired by https://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte
L = Len(s)
If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
nextPerm = ""
Exit Function
End If
' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
c(ii) = Asc(Mid(s, ii, 1))
Next ii
' find the largest "tail":
For ii = L - 1 To 1 Step -1
If c(ii) < c(ii + 1) Then Exit For
Next ii
' if we complete the loop without break, ii will be zero
If ii = 0 Then
nextPerm = "**done**"
Exit Function
End If
' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
If c(jj) > c(ii) Then
' swap elements
temp = c(jj)
c(jj) = c(ii)
c(ii) = temp
Exit For
End If
Next jj
' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
nextPerm = nextPerm & Chr(c(jj))
Next jj
End Function
You can test it simply by adding it to a VBA module in your spreadsheet, and saving the workbook with .xlsm extension. Then you can type =nextPerm("abcd") in cell A1, and it should give you the next permutation - "abdc". Typing =nextPerm(A1) in A2 will compute the one after that, etc. You could copy all the way down the spreadsheet, and get every value.
If you copy the cells to a range that goes beyond the last permutation, it will return "**done**" as value for the first time this happens; and when you feed it "**done**" as input, it will return blank. This makes it obvious where things stop.
Take a look at this function -- it will list all possible permutations of a set of numbers using recursion.
http://www.vb-helper.com/howto_permute.html
It's for VB6 but it should be basically working in the Excel's implementation of VBA too.
Anyway, I know I shouldn't be responding to other comments here in the answer, I'm really sorry. It's just that the author Simone S said "If anyone is interested in using the resulting function just ask me", however, there's no way to contact the person other than this. Simone, please, I've been looking for a Shapley-Shubik algorithm for hours. Could you please point me to the description of how to compute the index or the resulting function?