All,
I have an Excel spreadsheet which gathers files from various locations which have version numbers at the end of their name.
eg
Filea_v1.1.xlsm
Filea_v1.1.1.xlsm
Filea_v9.1.xlsm
Filea_v11.1.1.xlsm
I have already stripped the details of the file and left with the version number, but I'm finding it hard to code to get the latest version. When using a simple
If LatestVersion > LatestVersion_Last
' 11.1.1 > 9.1
I get a FALSE output as it thinks the 9.1 is greater than 11.1.1 (as its held in a string). I can't convert to a number that I'm aware of as it contains more than one decimal place.
Does anyone have any suggestions?
Thanks
This function returns 1 if the version of the first input string is bigger, -1 if the second one is bigger and 0 if both are equal:
Function Compare(a As String, b As String) As Integer
Dim n As Integer
Dim aarr() As String
Dim barr() As String
Dim av As Integer
Dim bv As Integer
aarr = Split(a, ".")
barr = Split(b, ".")
n = LBound(aarr)
Do
av = -1
If UBound(aarr) > i - 1 Then av = CInt(aarr(i))
bv = -1
If UBound(barr) > i - 1 Then bv = CInt(barr(i))
If av = -1 And bv = -1 Then
Compare = 0
Exit Function
End If
If av > bv Then
Compare = 1
Exit Function
End If
If av < bv Then
Compare = -1
Exit Function
End If
i = i + 1
Loop
End Function
Public Fucntion CompareVersion( strVersion1 as String, strVersion2 as String)
strVersion1 = "Filea_v11.1.1.xlsm"
strVersion2 = "Filea_v9.1.xlsm"
strVersion1 = Replace(strVersion1, "Filea_v", "") 'remove prefix
strVersion1 = Replace(strVersion1, ".xlsm", "") ' remove suffix
strVersion1 = Replace(strVersion1, ".", "") 'remove dots
strVersion2 = Replace(strVersion1, "Filea_v", "") 'remove prefix
strVersion2 = Replace(strVersion1, ".xlsm", "") ' remove suffix
strVersion2 = Replace(strVersion1, ".", "") 'remove dots
Dim strVersionArray1 as String()
Dim strVersionArray2 as String()
strVersionArray1 = Split(strVersion1,".")
strVersionArray2 = Split(strVersion2,".")
Dim i as Integer
For i=LBound(strVersionArray1) To UBound(strVersionArray2)
If (Cint(strVersionArray1(i))>Cint(strVersionArray2(i))) Then
'strVerion1 is greater than strVersion2
GoTo EXIT_FUNC:
Else If (Cint(strVersionArray1(i))<Cint(strVersionArray2(i))) Then
'strVerion is greater than strVersion2
GoTo EXIT_FUNC:
Else If (Cint(strVersionArray1(i))=Cint(strVersionArray2(i))) Then
'we need to examine the next segment of the array
End if
Next i
EXIT_FUNC:
End Function
I think you could try something like this:
Function FctLatest(ByVal LatestVersion As String, ByVal LatestVersion_Last As String) As Boolean
Dim comparedNew, comparedOld As String
'Loop to remove the versions one by one
Do
'For the new version
comparedNew = CutString(comparedNew, LatestVersion)
'For the previous version
comparedOld = CutString(comparedOld, LatestVersion_Last)
'we eliminate the case of equal versions
If CInt(comparedNew) > CInt(comparedOld) Then
FctLatest = True
GoTo endFunction
ElseIf CInt(comparedNew) < CInt(comparedOld) Then
FctLatest = False
GoTo endFunction
End If
Loop While InStr(LatestVersion_Last, ".") <> 0 Or InStr(LatestVersion, ".") <> 0
'For the new version
comparedNew = CutString(comparedNew, LatestVersion)
'For the previous version
comparedOld = CutString(comparedOld, LatestVersion_Last)
'we eliminate the case of equal versions, and choose the first one input
If CInt(comparedNew) > CInt(comparedOld) Then
FctLatest = True
ElseIf CInt(comparedNew) < CInt(comparedOld) Then
FctLatest = False
End If
endFunction:
End Function
Private Function CutString(ByVal ReturnedString, ByRef InputString As String) As String
'For latest version
If InStr(InputString, ".") = 0 Then
ReturnedString = InputString
Else
ReturnedString = Left(InputString, InStr(InputString, ".") - 1) 'Adding the first part of the version
InputString = Right(InputString, Len(InputString) - InStr(InputString, ".")) 'Removing the first part of the version
End If
CutString = ReturnedString
End Function
It returns a boolean comparing the versions you're interested in.
Regards,
Pierre.
Edit: just added cases, as it wasn't functional in the first place.
Related
I am writing a VBA code to add +2 to any string of numbers that are put in the function.
It works fine, until it reaches 6 and 7, then it breaks. I really have no clue why that is.
If you are wondering why I am doing this, this is part of an encryption algorithm and it is specifically looking to encrypt digits in a string.
My code is:
Sub AddNumbers()
Dim Nos As String
Dim AddNo As String
Dim Found As Boolean
Dim Split()
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
Length = Len(Nos)
ReDim Split(Length)
For i = 1 To Length
Found = False
Split(i) = Mid(Nos, i, 1)
For O = 48 To 55
If Split(i) = Chr(O) Then
Split(i) = Chr(O + 2)
Found = True
Exit For
End If
Next O
If Split(i) = Chr(56) Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) Then
Split(i) = Chr(49)
End If
Next i
AddNo = Join(Split, "")
Sheets("Sheet1").Range("U3").Value = AddNo
End Sub
I would really appreciate an insight to why it is breaking at 6 and 7.
Take me a moment, but you are double adding.
Look at your loop. When you encounter 6 (Char(54)) you add 2 and have 8 (Char(56)).
But then, after your loop you are testing again for same Split(i). Char for 6 and 7 are now accordingly 56 and 57 - so you add another 2 to them.
If Split(i) = Chr(56) And Found = False Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) And Found = False Then
Split(i) = Chr(49)
End If
Use the actual function Split:
Sub AddNumbers()
Dim Nos As String
Dim AddNo As String
Dim Found As Boolean
Dim SplitStr() As String
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
SplitStr = Split(Nos, "-")
Dim i As Long
For i = LBound(SplitStr) To UBound(SplitStr)
Dim vlue As String
vlue = StrConv(SplitStr(i), vbUnicode)
Dim substr() As String
substr = Split(Left(vlue, Len(vlue) - 1), vbNullChar)
Dim j As Long
For j = LBound(substr) To UBound(substr)
Select Case substr(j)
Case 8
substr(j) = 0
Case 9
substr(j) = 1
Case Else
substr(j) = substr(j) + 2
End Select
Next j
SplitStr(i) = Join(substr, "")
Next i
AddNo = Join(SplitStr, "-")
Sheets("Sheet1").Range("U3").Value = AddNo
End Sub
The overall problem is that you are using the Chr codes for numbers and not actual numbers. This method only returns 1 digit because a Chr() refers to a list of single characters.
You are going to need to use Split (mySplit = Split(Nos,"-")) to return each number and work with those.
The lines
If Split(i) = Chr(56) Then
Split(i) = Chr(48)
ElseIf Split(i) = Chr(57) Then
Split(i) = Chr(49)
End If
has me confused. You are saying if the value is "8" change to "0" and if it is "9" change to "1"
This is another way to do it:
Sub AddNumbers()
Dim Nos As String, Nos2 As String
Dim NumSplit As Variant
Dim Num As Variant
Dim tmp As String
Dim i As Long
Nos = "0-1-2-3-4-5-6-7-8-9-10"
Sheets("Sheet1").Range("U2").Value = Nos
NumSplit = Split(Nos, "-")
For Each Num In NumSplit
For i = 1 To Len(Num)
tmp = tmp & Mid(Num, i, 1) + 2
Next i
Nos2 = Nos2 & tmp & "-"
tmp = ""
Next Num
Nos2 = Left(Nos2, Len(Nos2) - 1)
Sheets("Sheet1").Range("U3").Value = Nos2
End Sub
It's a bit messy, but shows the basic idea of splitting the original array into the separate numbers.
The For....Next loop inside the For...Each loop takes care of any numbers with more than one digit (giving the 32).
I was hoping to receive help editing this helpful piece of code:
Function ListSearchB(text As String, wordlist As String, Optional caseSensitive As Boolean = False)
Dim strMatches As String
Dim res As Variant
Dim arrWords() As String
arrWords = Split(wordlist)
On Error Resume Next
Err.Clear
For Each word In arrWords
If caseSensitive = False Then
res = InStr(LCase(text), LCase(word))
Else
res = InStr(text, word)
End If
If res > 0 Then
strMatches = strMatches & word
End If
Next word
If Len(strMatches) <> 0 Then
strMatches = Right(strMatches, Len(strMatches))
End If
ListSearchB = strMatches
End Function
This code works excellent for what it does currently. First it selects the text string to compare, then selects the array of comma separated words its looking to find matches to. If any of the words in the text string match to a word in the array it will return that match.
What I'm looking to add to it is to be able to select the first cell with text, then a second cell with text, and then the array itself and return any and all matches from both selected cells that match.
I tried all day trying to get it to work but I've been getting errors each time.
example would look like:
A1: apples taste better than the oranges
B1: strawberries are the best berry
C1(array): apples, strawberries, blueberries, peaches, oranges
D1(output): apples oranges strawberries
Some functions to help you:
'To check if an element is within a specific Array, Object, Range, String, etc.
Public Function isInArray(ByVal itemSearched As Variant, ByVal aArray As Variant) As Boolean
Dim item As Variant
If VarType(aArray) >= vbArray Or VarType(aArray) = vbObject Or VarType(aArray) = vbDataObject Or TypeName(aArray) = "Range" Then
For Each item In aArray
If itemSearched = item Then
isInArray = True
Exit Function
End If
Next item
isInArray = False
ElseIf VarType(aArray) = vbString Then
isInArray = InStr(1, aArray, itemSearched, vbBinaryCompare) > 0 'Comparing character by character
Else
On Error Resume Next
isInArray = Not IsError(Application.Match(itemSearched, aArray, False)) 'Slow on large arrays
Err.Clear: On Error GoTo 0
End If
End Function
'To check if a word is within a sentence-like string
Public Function isInStrArray(ByVal itemSearched As Variant, ByVal strSource As Variant) As Boolean
Dim strArr As Variant
isInStrArray = False
If VarType(itemSearched) = vbString And VarType(strSource) = vbString Then
itemSearched = Trim(itemSearched): strSource = Trim(strSource)
If Len(itemSearched) > 0 And Len(strSource) > 0 Then
strArr = Split(strSource) 'Splitting at each space
isInStrArray = isInArray(itemSearched, strArr)
Erase strArr
End If
End If
End Function
I wrote a function for calc to split a cell before a word containing certain characters:
Function sidx(inputstr) As Integer
Dim newString As String
newString = ""
Dim last_space_idx As String
last_space_idx = 0
Dim l As Integer
'l = (inputstr.Length - 1) was ported from js on google sheets
l = Len(inputstr) - 1
For i = 0 To l
If inputstr(i) = " " Then
last_space_idx = i
End If
If ("’aeiou".Indexof( inputstr(i) ) > 0) Then
sidx = last_space_idx
End If
Next i
sidx = last_space_idx
End Function
for some reason libreoffice has trouble parsing this and complains about mismatched parenthesis or missing Then at the last If statement. Any ideas?
So thanks everyone for all the help - there are many pitfalls porting javascript to libreoffice vba and the interpreter is not that useful... You spotting most of the issues!
Letter extraction was also broken and as I originally believed the brackets was not the real issue!
For closure here is the working version
Function sidx (inputstr As String) As Integer
Dim newString as String
newString = ""
Dim last_space_idx as String
last_space_idx = 0
Dim l as Integer
l = Len(inputstr) -1
For i = 0 to l
letter = Mid(cstr(inputstr),i+1,1)
If letter = " " Then
last_space_idx = i
End If
'If ("’āēīōū".Indexof(inputstr(i))) > 0 Then
If InStr("\’āēīōū",letter) > 0 Then
sidx = last_space_idx
End If
Next i
sidx = last_space_idx
End Function
How to make a style as a bookmark in word 2010?
You won't be able to use most of the text in the document as the bookmark name. It is just illegal to use certain characters in a bookmark name in Word/VBA. It may be possible to add such characters in bookmark names in an XML format of the document, so if it is required, you can ask a separate question.
This feels like way too much code to post on SO. You really need to explain what framework you have in place and tell us where your hurdles are. We can't do this again. "Works for me". If you have any questions though don't hesitate to ask.
Run the "RunMe" macro at the bottom.
Private Function IsParagraphStyledWithHeading(para As Paragraph) As Boolean
Dim flag As Boolean: flag = False
If InStr(1, para.Style, "heading", vbTextCompare) > 0 Then
flag = True
End If
IsParagraphStyledWithHeading = flag
End Function
Private Function GetTextRangeOfStyledParagraph(para As Paragraph) As String
Dim textOfRange As String: textOfRange = para.Range.Text
GetTextRangeOfStyledParagraph = textOfRange
End Function
Private Function BookmarkNameAlreadyExist(bookmarkName As String) As Boolean
Dim bookmark As bookmark
Dim flag As Boolean: flag = False
For Each bookmark In ActiveDocument.Bookmarks
If bookmarkName = bookmark.name Then
flag = True
End If
Next
BookmarkNameAlreadyExist = flag
End Function
Private Function CreateUniqueBookmarkName(bookmarkName As String)
Dim uniqueBookmarkName As String
Dim guid As String: guid = Mid$(CreateObject("Scriptlet.TypeLib").guid, 2, 36)
guid = Replace(guid, "-", "", , , vbTextCompare)
uniqueBookmarkName = bookmarkName & guid
CreateUniqueBookmarkName = uniqueBookmarkName
End Function
Private Function BookmarkIt(rng As Range, bookmarkName As String)
Dim cleanName As String: cleanName = MakeValidBMName(bookmarkName)
If BookmarkNameAlreadyExist(cleanName) Then
cleanName = CreateUniqueBookmarkName(cleanName)
End If
ActiveDocument.Bookmarks.Add name:=cleanName, Range:=rng
End Function
''shamelessly stolen from gmaxey at http://www.vbaexpress.com/forum/showthread.php?t=37674
Private Function MakeValidBMName(strIn As String)
Dim pFirstChr As String
Dim i As Long
Dim tempStr As String
strIn = Trim(strIn)
pFirstChr = Left(strIn, 1)
If Not pFirstChr Like "[A-Za-z]" Then
strIn = "A_" & strIn
End If
For i = 1 To Len(strIn)
Select Case Asc(Mid$(strIn, i, 1))
Case 49 To 58, 65 To 90, 97 To 122
tempStr = tempStr & Mid$(strIn, i, 1)
Case Else
tempStr = tempStr & "_"
End Select
Next i
tempStr = Replace(tempStr, " ", " ")
MakeValidBMName = tempStr
End Function
Sub RunMe()
Dim para As Paragraph
Dim textOfPara As String
For Each para In ActiveDocument.Paragraphs
If IsParagraphStyledWithHeading(para) Then
textOfPara = GetTextRangeOfStyledParagraph(para)
If para.Range.Bookmarks.Count < 1 Then
BookmarkIt para.Range, textOfPara
End If
End If
Next
End Sub
I have string "ololo123".
I need get position of first digit - 1.
How to set mask of search ?
Here is a lightweight and fast method that avoids regex/reference additions, thus helping with overhead and transportability should that be an advantage.
Public Function GetNumLoc(xValue As String) As Integer
For GetNumLoc = 1 To Len(xValue)
If Mid(xValue, GetNumLoc, 1) Like "#" Then Exit Function
Next
GetNumLoc = 0
End Function
Something like this should do the trick for you:
Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPositionOfFirstNumericCharacter = i
Exit Function
End If
Next i
End Function
You can then call it like this:
Dim iPosition as Integer
iPosition = GetPositionOfFirstNumericCharacter("ololo123")
Not sure on your environment, but this worked in Excel 2010
'Added reference for Microsoft VBScript Regular Expressions 5.5
Const myString As String = "ololo123"
Dim regex As New RegExp
Dim regmatch As MatchCollection
regex.Pattern = "\d"
Set regmatch = regex.Execute(myString)
MsgBox (regmatch.Item(0).FirstIndex) ' Outputs 5
I actually have that function:
Public Function GetNumericPosition(ByVal s As String) As Integer
Dim result As Integer
Dim i As Integer
Dim ii As Integer
result = -1
ii = Len(s)
For i = 1 To ii
If IsNumeric(Mid$(s, i, 1)) Then
result = i
Exit For
End If
Next
GetNumericPosition = result
End Function
You could try regex, and then you'd have two problems. My VBAfu is not up to snuff, but I'll give it a go:
Function FirstDigit(strData As String) As Integer
Dim RE As Object REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "[0-9]"
End With
Set REMatches = RE.Execute(strData)
FirstDigit = REMatches(0).FirstIndex
End Function
Then you just call it with FirstDigit("ololo123").
If speed is an issue, this will run a bit faster than Robs (noi Rob):
Public Sub Example()
Const myString As String = "ololo123"
Dim position As Long
position = GetFirstNumeric(myString)
If position > 0 Then
MsgBox "Found numeric at postion " & position & "."
Else
MsgBox "Numeric not found."
End If
End Sub
Public Function GetFirstNumeric(ByVal value As String) As Long
Dim i As Long
Dim bytValue() As Byte
Dim lngRtnVal As Long
bytValue = value
For i = 0 To UBound(bytValue) Step 2
Select Case bytValue(i)
Case vbKey0 To vbKey9
If bytValue(i + 1) = 0 Then
lngRtnVal = (i \ 2) + 1
Exit For
End If
End Select
Next
GetFirstNumeric = lngRtnVal
End Function
An improved version of spere's answer (can't edit his answer), which works for any pattern
Private Function GetNumLoc(textValue As String, pattern As String) As Integer
For GetNumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, GetNumLoc, Len(pattern)) Like pattern Then Exit Function
Next
GetNumLoc = 0
End Function
To get the pattern value you can use this:
Private Function GetTextByPattern(textValue As String, pattern As String) As String
Dim NumLoc As Integer
For NumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, NumLoc, Len(pattern)) Like pattern Then
GetTextByPattern = Mid(textValue, NumLoc, Len(pattern))
Exit Function
End If
Next
GetTextByPattern = ""
End Function
Example use:
dim bill as String
bill = "BILLNUMBER 2202/1132/1 PT2200136"
Debug.Print GetNumLoc(bill , "PT#######")
'Printed result:
'24
Debug.Print GetTextByPattern(bill , "PT#######")
'Printed result:
'PT2200136