I have a set which has an unknown number of objects. I want to associate a label to each one of these objects. Instead of labeling each object with a number I want to label them with letters.
For example the first object would be labeled A the second B and so on.
When I get to Z, the next object would be labeled AA
AZ? then BA, BB, BC.
ZZ? then AAA, AAB, AAC and so on.
I'm working using Mapbasic (similar to VBA), but I can't seem to wrap my head around a dynamic solution. My solution assumes that there will be a max number of objects that the set may or may not exceed.
label = pos1 & pos2
Once pos2 reaches ASCII "Z" then pos1 will be "A" and pos2 will be "A". However, if there is another object after "ZZ" this will fail.
How do I overcome this static solution?
Basically what I needed was a Base 26 Counter. The function takes a parameter like "A" or "AAA" and determines the next letter in the sequence.
Function IncrementAlpha(ByVal alpha As String) As String
Dim N As Integer
Dim num As Integer
Dim str As String
Do While Len(alpha)
num = num * 26 + (Asc(alpha) - Asc("A") + 1)
alpha = Mid$(alpha, 2,1)
Loop
N = num + 1
Do While N > 0
str = Chr$(Asc("A") + (N - 1) Mod 26) & str
N = (N - 1) \ 26
Loop
IncrementAlpha = str
End Function
If we need to convert numbers to a "letter format" where:
1 = A
26 = Z
27 = AA
702 = ZZ
703 = AAA etc
...and it needs to be in Excel VBA, then we're in luck. Excel's columns are "numbered" the same way!
Function numToLetters(num As Integer) As String
numToLetters = Split(Cells(1, num).Address(, 0), "$")(0)
End Function
Pass this function a number between 1 and 16384 and it will return a string between A and XFD.
Edit:
I guess I misread; you're not using Excel. If you're using VBA you should still be able to do this will the help of an reference to an Excel Object Library.
This should get you going in terms of the logic. Haven't tested it completely, but you should be able to work from here.
Public Function GenerateLabel(ByVal Number As Long) As String
Const TOKENS As String = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
Dim i As Long
Dim j As Long
Dim Prev As String
j = 1
Prev = ""
Do While Number > 0
i = (Number Mod 26) + 1
GenerateLabel = Prev & Mid(TOKENS, i, 1)
Number = Number - 26
If j > 0 Then Prev = Mid(TOKENS, j + 1, 1)
j = j + Abs(Number Mod 26 = 0)
Loop
End Function
Related
I am working a code, and I have a problem with Excel's XIRR function.
You have a matrix with 2 columns (dates and amounts), so the inputs are the matrix, a date, and a quantity. Inside the code it takes the values below the date you used as input, makes a new array with those values, and add also the date and amount you entered as inputs. And the output should be the XIRR of that array. It doesn´t seem to work. It works with IRR, with dates are an important input. Does someone know how to fix this problem? Thanks in advance!
Function Retorno(matriz As Range, dia As Date, valuacion As Double) As Double
Dim Datos As Range
Dim Aux1()
Dim Aux2()
Dim i, j, m, n As Integer
Set Datos = matriz
j = 0
For i = 1 To Datos.Rows.Count
If Datos(i, 1) <= dia Then
j = j + 1
End If
Next i
ReDim Aux1(1 To j + 1)
ReDim Aux2(1 To j + 1)
For n = 1 To j + 1
Aux1(n) = Datos(n, 2)
Next n
Aux1(j + 1) = valuacion
For m = 1 To j + 1
Aux2(m) = Datos(m, 1)
Next m
Aux2(j + 1) = dia
Retorno = WorksheetFunction.Xirr(Aux1, Aux2)
End Function
Your last Aux2(j + 1) = dia is overwriting the second date in the array with the first date, giving you two identical dates in the date array.
Possibly you want to delete that line.
The other possible answer to this problem is to convert the date to numbers if you do this: Aux2(m) = Datos(m, 1)*1 XIRR will work too.
I have a routing sequence for a set of machines on an assembly line. Each route has to go through the entire line (that is, if you only run the first and second machine, you still account for the distance from the second to the end of the line).
I have six different machines (720 possible combinations of machines) with fixed distances between each location on the line. The distance between the first and second machine is 100', the distance between second and third is 75', third and fourth is 75', fourth and fifth is 25', and fifth and sixth is 25'.
I have 4 different products that have to run down the line, and each of them have a fixed routing.
My problem is, how do I set up a vba code or solver that will allow me to run through all possible combinations of the line setup and determine the optimal setup for this line? Any machine can be placed at any location, as long as it optimizes the result!
The four product routes are :
A - B - C - D - F
A - C - B - D – E - F
A - F - E - D - C - B - A - F
A - C - E - B - D – F
Running through all possible combinations - if you really need to do that - is a job for something like Heap's algorithm, although I prefer the plain changes method:
Sub Evaluate(Lineup() As String)
' dummy evaluation, just output the permutation
Dim OffCell As Long
For OffCell = LBound(Lineup, 1) To UBound(Lineup, 1)
ActiveCell.Offset(0, OffCell).Value = Lineup(OffCell)
Next OffCell
ActiveCell.Offset(1, 0).Activate
End Sub
Sub AllPerms(Lineup() As String)
' Lineup is a 1-D array indexed at 1
Dim LSize As Long
Dim Shift() As Long
Dim Tot As Long
Dim Idx As Long
Dim Level As Long
Dim Change As Long
Dim Offset As Long
Dim TempStr As String
LSize = UBound(Lineup)
ReDim Shift(LSize)
'count of permutations, set initial changes
Tot = 1
For Idx = 2 To LSize
Tot = Tot * Idx
Shift(Idx) = 1 - Idx
Next Idx
Shift(1) = 2 ' end condition
' go through permutations
For Idx = 1 To Tot
' check this one
Call Evaluate(Lineup)
' switch for the next
Level = LSize
Offset = 0
Change = Abs(Shift(Level))
Do While Change = 0 Or Change = Level
If Change = 0 Then Shift(Level) = 1: Offset = Offset + 1
If Change = Level Then Shift(Level) = 1 - Level
Level = Level - 1
Change = Abs(Shift(Level))
Loop
Shift(Level) = Shift(Level) + 1
Change = Change + Offset
TempStr = Lineup(Change)
Lineup(Change) = Lineup(Change + 1)
Lineup(Change + 1) = TempStr
Next Idx
End Sub
Sub ABCDEF_case()
Dim LU(6) As String
LU(1) = "A"
LU(2) = "B"
LU(3) = "C"
LU(4) = "D"
LU(5) = "E"
LU(6) = "F"
Call AllPerms(LU)
End Sub
I am trying to convert some old VB code to .Net but am having a problem with the Rnd function.
Old Code
Private Function Decode() As String
Dim r As Integer
Dim x As Integer
Dim c As Integer
Dom Code As String = "m[n-Msr0Xn*ca8qiGeIL""7'&;,_*EV{M;[{2bEmg8u!^s*+O37!692{-Y4IS"
x = Int(Rnd(-7))
For r = 1 To Len(Code)
x = Int(Rnd() * 96)
c = Asc(Mid(Code, r, 1))
c = c + x
If c >= 126 Then c = c - 126 + 32
Decode = Decode & Chr$(c)
Next
End Function
The decoded text is "Bet you needed more than a pencil and paper to get this one!"
This is what I have done:
Private Function Decode() As String
Dim r As Integer
Dim x As Integer
Dim c As Integer
Dim Answer As String
Dim Code As String = "m[n-Msr0Xn*ca8qiGeIL""7'&;,_*EV{M;[{2bEmg8u!^s*+O37!692{-Y4IS"
x = CType(Microsoft.VisualBasic.VBMath.Rnd(-7), Integer)
For r = 0 To sList.Length - 1
x = CType(Microsoft.VisualBasic.VBMath.Rnd() * 96 - 0.5, Integer)
c = Asc(sList.Substring(r, 1))
c = c + x
If c >= 126 Then c = c - 126 + 32
Answer &= Chr(c)
Next
Return Answer
End Function
but this is what I get "Bet you needed morB th(n a pencil and paper to get this one!"
I suspect its how I am castng to an int but I can't figure out how.
When I run your "Old Code" (after correcting the typos) under Office VBA (which should have the same Rnd implementation as VB6), I get the same result as you say you get from VB.Net. Therefore, there must be an error in the string assigned to Code.
Public Function Decode() As String
Dim r As Integer
Dim x As Integer
Dim c As Integer
Dim Code As String
Code = "m[n-Msr0Xn*ca8qiGeIL""7'&;,_*EV{M;[{2bEmg8u!^s*+O37!692{-Y4IS"
x = Int(Rnd(-7))
For r = 1 To Len(Code)
x = Int(Rnd() * 96)
c = Asc(Mid(Code, r, 1))
c = c + x
If c >= 126 Then c = c - 126 + 32
Decode = Decode & Chr$(c)
Next
End Function
Thanks to TnTinMan for leading me to the solution. The problem was created when I copied the string. I used a I instead of an l. The font that was used has these two characters looking identical. I also mistook ' for `.
so basically all I had to do was subtract .5
I am banging my head against the wall for a while now trying different techniques.
None of them are working well.
I have two strings.
I need to compare them and get an exact percentage of match,
ie. "four score and seven years ago" TO "for scor and sevn yeres ago"
Well, I first started by comparing every word to every word, tracking every hit, and percentage = count \ numOfWords. Nope, didn't take into account misspelled words.
("four" <> "for" even though it is close)
Then I started by trying to compare every char in each char, incrementing the string char if not a match (to count for misspellings). But, I would get false hits because the first string could have every char in the second but not in the exact order of the second. ("stuff avail" <> "stu vail" (but it would come back as such, low percentage, but a hit. 9 \ 11 = 81%))
SO, I then tried comparing PAIRS of chars in each string. If string1[i] = string2[k] AND string1[i+1] = string2[k+1], increment the count, and increment the "k" when it doesn't match (to track mispellings. "for" and "four" should come back with a 75% hit.) That doesn't seem to work either. It is getting closer, but even with an exact match it is only returns 94%. And then it really gets screwed up when something is really misspelled. (Code at the bottom)
Any ideas or directions to go?
Code
count = 0
j = 0
k = 0
While j < strTempName.Length - 2 And k < strTempFile.Length - 2
' To ignore non letters or digits '
If Not strTempName(j).IsLetter(strTempName(j)) Then
j += 1
End If
' To ignore non letters or digits '
If Not strTempFile(k).IsLetter(strTempFile(k)) Then
k += 1
End If
' compare pair of chars '
While (strTempName(j) <> strTempFile(k) And _
strTempName(j + 1) <> strTempFile(k + 1) And _
k < strTempFile.Length - 2)
k += 1
End While
count += 1
j += 1
k += 1
End While
perc = count / (strTempName.Length - 1)
Edit: I have been doing some research and I think I initially found the code from here and translated it to vbnet years ago. It uses the Levenshtein string matching algorithm.
Here is the code I use for that, hope it helps:
Sub Main()
Dim string1 As String = "four score and seven years ago"
Dim string2 As String = "for scor and sevn yeres ago"
Dim similarity As Single =
GetSimilarity(string1, string2)
' RESULT : 0.8
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Max(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function
Did not work for me unless one (or both) of following are done:
1) use option compare statement "Option Compare Text" before any Import declarations and before Class definition (i.e. the very, very first line)
2) convert both strings to lowercase using .tolower
Xavier's code must be correct to:
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While
This function goes through all integers and picks out binary values with only five ones and writes them to the spreadsheet.
To run this For x = 1 To 134217728 would take 2.5 days!!!! Help!
How could I speed this up?
Function D2B(ByVal n As Long) As String
n = Abs(n)
D2B = ""
Do While n > 0
If n = (n \ 2) * 2 Then
D2B = "0" & D2B
Else
D2B = "1" & D2B
n = n - 1
End If
n = n / 2
Loop
End Function
Sub mixtures()
Dim x As Long
Dim y As Integer
Dim fill As String
Dim mask As String
Dim RowOffset As Integer
Dim t As Date
t = Now
fill = ""
For x = 1 To 134217728
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
Debug.Print mask
If x > 100000 Then Exit For
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
RowOffset = RowOffset + 1
For y = 1 To Len(mask)
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
Range("mix").Offset(RowOffset).Cells(y) = Mid(mask, y, 1)
Next
Next
Debug.Print DateDiff("s", Now, t)
End Sub
By first sight guess, I think the problem lies in the fact that you do that cell by cell, which causes many read and write accesses.
You should do it range by range, like
vArr = Range("A1:C1000").Value
' it is array now, do something here effeciently
Range("A1:C1000").Value = vArr
You want find all 28bit numbers with 5 1s
There are 28*27*26*25*24/5/4/3/2=98280 such numbers
The following code took ~10 seconds on my PC:
lineno = 1
For b1 = 0 To 27
For b2 = b1 + 1 To 27
For b3 = b2 + 1 To 27
For b4 = b3 + 1 To 27
For b5 = b4 + 1 To 27
Cells(lineno, 1) = 2 ^ b1 + 2 ^ b2 + 2 ^ b3 + 2 ^ b4 + 2 ^ b5
lineno = lineno + 1
Next
Next
Next
Next
Next
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
The above line of code does the same thing (CStr(D2B(x))) twice.
Store the result of CStr(D2B(x)) in a variable & use that variable in the above line of code.
I've got 2 suggestions:
Get rid of the substitution command by counting the ones/zeroes in D2B and return an empty string if the count does not equal 5
Write these pre-filtered bitstrings to an array first and copy the array directly to the cells when finished.
Something like
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
The array-copy-trick greatly improves performance!