I have a code where I'm adding last rows to collection which should be later transformed to an array and final step is to get last row with the least number of cells in it.
My current code is:
Dim lastc, lastc2, lastr, FindColNumber, FindColNumber2 as Long
Dim FindCol as Range
Dim col As New Collection
Dim CollectionToArray As Variant
Set FindCol = 1 'example
FindColNumber = FindCol.Column
lastc = FindColNumber + 1
Set FindCol2 = 5 'example
FindColNumber = FindCol2.Column
lastc2 = FindColNumber - 1
For R = lastc2 To lastc Step -1
lastc2 = R
col.Add Cells(ws.Rows.count, R).End(xlUp).Row
Next R
Debug.Print WorksheetFunction.Min(CollectionToArray(col))
Public Function CollectionToArray(myCol As Collection) As Variant
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.count - 1)
For cnt = 0 To myCol.count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
I am still getting Type Mismatch error and when hovering over CollectionToArray(Col)) I see "Object variable or With block variable not set".
Thank you.
i foung similiar topic, but i can t apply completily that solution to my needs... I want to upgrade excel workbook at my job by making it more auto-entry capable.
Mostly i use excel functions, but sometimes i need some VBA coding, which im not very familiar with. So my problem is, that i need something like this mentioned on this thread. How to get the first and last numbers in a sequence
I have box numbers in different sequince in ascening order starting from "A4" to X on
Sheet1. Example Box numbers: M004935149,M004935150,M004935151,M004935202,M004935203,M004935204,M004935205, is it possible when i copy&paste(values) to sheet2 from "A4" to X (depenting on number of boxes copied) to make a string, sentence or whatever is called in specific form in some other cells. M004935149-151 // M004935202-205. I used code from topic in link above, it can make half job done but i can t figure it out how to make entry from desired cell range and display them on worksheet, and to display values in desired format. Link of screen shoots from my example is following:
I hope that someone can help. Thanks in advance.
Check this
Option Explicit
Sub test2()
Dim ws As Worksheet
Dim arr() As String, result As String, letter As String, cellValue As String, tempLastElement As String
Dim lastColumn As Long, counter As Long
Dim firstColumn As Integer, targetRow As Integer, i As Integer
Set ws = Worksheets("Sheet1")
firstColumn = 1 'number of first column with target data
targetRow = 1 'number of row with target data
lastColumn = ws.Range(ws.Cells(targetRow, firstColumn), ws.Cells(targetRow, Columns.Count).End(xlToLeft).Columns).Count
ReDim arr(1 To lastColumn - firstColumn + 1)
letter = Left(ws.Cells(targetRow, firstColumn).Value, 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
For i = 1 To UBound(arr)
cellValue = ws.Cells(targetRow, i).Value
arr(i) = Right(cellValue, Len(cellValue) - 1) 'if count of character in start of string will be more 1, replace 1 on to count of characters
Next i
ReDim sequenceArr(1 To UBound(arr))
sequenceArr(1) = arr(1)
counter = 2
For i = 1 To UBound(arr) - 1
If CLng(arr(i)) + 1 = CLng(arr(i + 1)) Then
tempLastElement = arr(i + 1)
sequenceArr(counter) = tempLastElement
Else
counter = counter + 1
sequenceArr(counter) = arr(i + 1)
counter = counter + 1
End If
Next
ReDim Preserve sequenceArr(1 To counter)
result = ""
counter = 1
For i = 1 To UBound(sequenceArr) - 1
If counter > UBound(sequenceArr) Then Exit For
If result = "" Then
result = letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
Else
result = result & "//" & letter & sequenceArr(counter) & "-" & Right(sequenceArr(counter + 1), 3)
counter = counter + 2
End If
Next
ws.Range("D4").Value = result
End Sub
Result on
I'm trying to find an index of the minimum value from sum(3) array. And it should be assigned to a variable min
min = index of minimum value
Should I sort the array first or is there any direct way of doing it?
Here is my code:
`Sub Min_index()
Dim Pt_array(3) As Single
Pt_array(0) = 0
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
Dim Ad_E_array(3) As Single
Dim Lo_E_array(3) As Single
Dim Bs_temp As Single
Dim i As Integer
i = 0
Do While i < 4
Bs_temp = BS
Ad_E_array(i) = Ad_E 'defined in previous Sub
Lo_E_array(i) = Lo_E 'defined in previous Sub
If Bs_temp + Pt_array(i) - Qth < BS_Maximum_limit Then
Bs_temp = Bs_temp + Pt_array(i) - Qth
Ad_E_array(i) = Ad_E_array(i) + 0
Lo_E_array(i) = Lo_E_array(i) + 0
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
Else
Lo_E_array(i) = Pt_array(i) - Qth - (BS_Maximum_limit - Bs_temp)
Bs_temp = BS_Maximum_limit
Call function_decide(int_forecast_hour - 1, Bs_temp, Qth + 1, Lo_E_array(i), Ad_E_array(i))
End If
i = i + 1
Loop
Dim sum(3) As Single
Dim min As Single
i = 0
Do While i < 4
sum(i) = Abs(Lo_E_array(i)) + Abs(Ad_E_array(i))
i = i + 1
Loop
End Sub`
You can receive the 1-based index position of the element containing the minimum value with the an Excel Application object's use of the worksheet's MIN function and MATCH function.
Sub wqewuiew()
Dim Pt_array(3) As Single, p As Long
Pt_array(0) = 1000
Pt_array(1) = 12.3
Pt_array(2) = 16.06
Pt_array(3) = 20.11
p = Application.Match(Application.Min(Pt_array), Pt_array, 0)
Debug.Print p '<~~ 'p' is 2 (I changed the value of the first array element)
End Sub
I've been trying to research this for a while now. I'm trying to write a function that will find the last populated row in column B (Starting at B9), and add the string values in column B into an array.
Any help would be much appreciated, thanks everyone.
Option Explicit
Function locationSum2(location) As Integer
Dim arrayLength As Integer
arrayLength = LastRowInColumn(2) - 9
Dim arrayPosition As Integer
Dim locationColumn() As String
ReDim locationColumn(0 To arrayLength) As String
Dim celltext As String
Dim i As Integer
For i = 0 To i = arrayLength
celltext = Cells((9 + i), 2).Text
locationColumn(i) = celltext
Next i
For arrayPosition = 0 To arrayPosition = UBound(locationColumn)
If location = locationColumn(arrayPosition) Then
locationSum2 = locationSum2 + Cells(arrayPosition + 9, 11).Value
End If
Next arrayPosition
locationSum2 = locationSum2
End Function
Following a comment, I also chopped the code way down to basically just a loop that check the argument against everything in column B instead of making an array.
Option Explicit
Function locationSum2(location) As Integer
Dim LastRow As Integer
LastRow = LastRowInColumn(2)
Dim i As Integer
For i = 9 To i = LastRow
If location = Cells(i, 2).Text Then
locationSum2 = locationSum2 + Cells(i, 11).Value
End If
Next i
locationSum2 = locationSum2
For whatever reason, it still doesn't seem to be reading Column B properly. It's returning a value of 0 so it doesn't seem to be finding a match.
You've setup the for loops incorrectly.
For i = 9 To i = LastRow
should be
For i = 9 To LastRow
I'm not sure if that is you're only problem, but lets start there
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?