I am doing a VBA Macro for Excel and I need to get the part of a file path that matches with a specific string.
I mean, I have a Variant called FileInfo that contains the path of the Workbook that I am using at that moment (inside a For), for example, Variant may look like:
C:\Users\myUser\Desktop\SVN-Folder\trunk\G\INC20825\Estimación Temporal_v01r00.xlsx
I want to make a function that returns only the part of the path that matches with "INC*" and if the path doesn't have that match, return null.
So the function in this case may return: INC20825
I tried with this but did not work
'This function returns the INC folder where is contained
Function INCFolder(FileInfo As Variant)
Dim i As Integer
If FileInfo Like "INC*" Then
i = InStr(FileInfo, "INC")
INCFolder = Mid(FileInfo, i, 8)
Else
INCFolder = Null
End If
End Function
EDIT with partial solution:
I made it working to get the 8 characters of INC* with the following code:
'This function returns the INC folder where is contained
Function INCFolder(FileInfo As Variant)
Dim i As Integer
i = InStr(FileInfo, "INC")
If i = 0 Then
INCFolder = Null
Else
INCFolder = Mid(FileInfo, i, 8)
End If
End Function
Problems will come when INC is bigger or smaller than 8
You can use Split to seperate your \ from your full path to PathArr array elements, and then loop through PathArr elements and look for "INC".
The code below will give you flexibility with the number of characters you have for "INC".
Code
Option Explicit
Sub test()
Const FullName = "C:\Users\myUser\Desktop\SVN-Folder\trunk\G\INC20825\Estimación Temporal_v01r00.xlsx"
Dim INCSection As String
INCSection = INCFolder(FullName)
End Sub
Function INCFolder(FileInfo As Variant) As String
Dim i As Long
Dim PathArr As Variant
If FileInfo Like "*INC*" Then
PathArr = Split(FileInfo, "\") ' split folders to array
For i = 0 To UBound(PathArr) ' loop through array and look for "*INC*"
If PathArr(i) Like "*INC*" Then
INCFolder = PathArr(i)
Exit Function
End If
Next i
Else
INCFolder = "Error!"
End If
End Function
Just add one more * in the Like:
Option Explicit
Public Const pathName = "C:\Folder\trunk\G\INC20825\Estimación Temporal_v01r00.xlsx"
Function INCFolder(FileInfo As Variant)
Dim i As Long
If FileInfo Like "*INC*" Then
i = InStr(FileInfo, "INC")
INCFolder = Mid(FileInfo, i, 8)
Else
INCFolder = False
End If
End Function
Just the alternate way to get the result
Function INCFolder(FileInfo As Variant)
If FileInfo Like "*INC*" Then
INCFolder = Mid(WorksheetFunction.Substitute(Mid(FileInfo, InStr(FileInfo, "\INC"), Len(FileInfo)), "\", "|", 2), 2, WorksheetFunction.Search("|", WorksheetFunction.Substitute(Mid(FileInfo, InStr(FileInfo, "\INC"), Len(FileInfo)), "\", "|", 2)) - 2)
Else
INCFolder = Null
End If
End Function
Related
I have a function LastItem which returns the last word from the string. It works fine for strings with value but for blanks like "" it fails.
I am checking if Split returned an Array. Even for blank string the IsArray() returns true. Is there a way to Fix it.
Errors are mentioned as comment in the code.
Sub test()
Debug.Print LastItem("a b c")
Debug.Print LastItem("a")
Debug.Print LastItem("") '''' ===> Error for this one
End Sub
Public Function LastItem(source As String) As String
Dim arr
arr = Split(source, Space(1))
If IsArray(arr) Then
LastItem = arr(UBound(arr)) '''' ===> For LastItem("") error is [Subscript out of range]
Else
LastItem = source
End If
End Function
Check if upper bound is greater than -1
Public Function LastItem(source As String) As String
Dim arr
arr = Split(source, Space(1))
'/ Check if upper bound is greater than -1
If UBound(arr) > -1 Then
LastItem = arr(UBound(arr))
Else
LastItem = source
End If
End Function
Split always returns an array so an IsArray check is unnecessary.
How about this? Bail early if the input is a zero-length string.
Public Function LastItem(source As String) As String
If source = vbNullString Then Exit Function
Dim arr
arr = Split(source, Space(1))
LastItem = arr(UBound(arr))
End Function
Trying to search on a ListBox. Specifically, I want to look at an array of items from the Cell, and for each one that matches an entry in the ListBox, I want it to select that List.
I copy-pasted some code that was supposed to let me find a string, but it keeps telling me:
Compile Error: Method or Data Member not found.
Any suggestions?
Relevant Code:
Public local_Target As Range
' local_Target is assigned in the sheet function to pass it here
Private Sub Network_ListBox_Enter()
' Get data in cell (if any)
Dim current_data As String
Dim entries() As String
current_data = local_Target.Value
If current_data = "" Then
Exit Sub
Else
entries = Split(current_data, vbNewLine)
End If
For Each Item In entries
FindMyString Item
Next Item
End Sub
Private Sub UserForm_Terminate()
Dim index As Integer
Dim result As String
' Iterate through the listbox and create the result, then assign to
' Target.value
For index = 0 To Network_ListBox.ListCount - 1
If Network_ListBox.Selected(index) Then
' stuff
If result = "" Then
result = Network_ListBox.List(index)
' ElseIf index = Network_ListBox.ListCount - 1 Then
' result = result + Network_ListBox.List(index)
Else
result = result + vbNewLine + Network_ListBox.List(index)
End If
End If
Next index
local_Target.Value = result
End Sub
Sub FindMyString(ByVal searchString As String)
' Ensure we have a proper string to search for.
If searchString <> "" Then
' Find the item in the list and store the index to the item.
Dim index As Integer
index = Me.Network_ListBox.FindString(searchString)
' Determine if a valid index is returned. Select the item if it is valid.
If index <> -1 Then
Network_ListBox.SetSelected index, True
'Else
' MessageBox.Show ("The search string did not match any items in the ListBox")
End If
End If
End Sub
I checked Intellisense and I don't think that Method is supported in VBA. Other documentations I've found refers to .Net Framework only as well. So maybe, it is not really supported in VBA, but regardless, you can create a function to do just that. Something like below.
Private Function SearchString(mysearch As String, mylist As Variant) As Long
Dim itm As Variant, idx As Long: idx = 0
If IsArray(mylist) Then
For Each itm In mylist
If mysearch = itm Then
SearchString = idx: Exit Function
End If
idx = idx + 1
Next
End If
SearchString = -1
End Function
And you can use it like this:
Private Sub CommandButton1_Click()
Dim i As Long
'do the search
i = SearchString("WhatImSearching", Me.ListBox1.List)
'select the item that match your search
If i <> -1 Then Me.ListBox1.Selected(i) = True
End Sub
I'm not saying that the function I created above is the most efficient way.
That is just an example to give you an idea for a workaround. HTH.
Important: This works in single column ListBox which have a 1D array list. If you need to work on multi-column ListBox, you'll have to tweak the function a little.
I would like to split the following string "2/3/4/4" for example and get each number and save them as a list.
I can split the string with the code split("2/3/4/4", "/") but then I cannot manage to put them in a list.
Any help is appreciated.
Yes, like engineersmnky says you can just return the results of Split() to a String array, like this:
Public Sub Test()
Dim results() As String
Dim i As Integer
results = Split("2/3/4/4", "/")
For i = LBound(results) To UBound(results)
MsgBox results(i)
Next i
End Sub
This would split "2/3/4/4" and put the numbers in A1:A4
Sub SplitAndList()
Dim nums As Variant, n As Integer
nums = Split("2/3/4/4", "/")
For n = 0 To UBound(nums)
Range("A" & n + 1) = nums(n)
Next n
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
Is there any way, in either VBA or C# code, to get a list of the existing macros defined in a workbook?
Ideally, this list would have a method definition signatures, but just getting a list of the available macros would be great.
Is this possible?
I haven't done vba for Excel in a long time, but if I remember well, the object model for the code was inaccessible through scripting.
When you try to access it, you receive the following error.
Run-time error '1004':
Programmatic access to Visual Basic Project is not trusted
Try:
Tools | Macro | Security |Trusted Publisher Tab
[x] Trust access to Visual Basic Project
Now that you have access to the VB IDE, you could probably export the modules and make a text search in them, using vba / c#, using regular expressions to find sub and function declarations, then delete the exported modules.
I'm not sure if there is an other way to do this, but this should work.
You can take a look the following link, to get started with exporting the modules.
http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E
This is where I got the information about giving thrusted access to the VB IDE.
Building on Martin's answer, after you trust access to the VBP, you can use this set of code to get an array of all the public subroutines in an Excel workbook's VB Project. You can modify it to only include subs, or just funcs, or just private or just public...
Private Sub TryGetArrayOfDecs()
Dim Decs() As String
DumpProcedureDecsToArray Decs
End Sub
Public Function DumpProcedureDecsToArray(ByRef Result() As String, Optional InDoc As Excel.Workbook) As Boolean
Dim VBProj As Object
Dim VBComp As Object
Dim VBMod As Object
If InDoc Is Nothing Then Set InDoc = ThisWorkbook
ReDim Result(1 To 1500, 1 To 4)
DumpProcedureDecsToArray = True
On Error GoTo PROC_ERR
Set VBProj = InDoc.VBProject
Dim FuncNum As Long
Dim FuncDec As String
For Each VBComp In VBProj.vbcomponents
Set VBMod = VBComp.CodeModule
For i = 1 To VBMod.countoflines
If IsSubroutineDeclaration(VBMod.Lines(i, 1)) Then
FuncDec = RemoveBlanksAndDecsFromSubDec(RemoveAsVariant(VBMod.Lines(i, 1)))
If LCase(Left(VBMod.Lines(i, 1), Len("private"))) <> "private" Then
FuncNum = FuncNum + 1
Result(FuncNum, 1) = FindToLeftOfString(InDoc.Name, ".") '
Result(FuncNum, 2) = VBMod.Name
Result(FuncNum, 3) = GetSubName(FuncDec)
Result(FuncNum, 4) = VBProj.Name
End If
End If
Next i
Next VBComp
PROC_END:
Exit Function
PROC_ERR:
GoTo PROC_END
End Function
Private Function RemoveCharFromLeftOfString(TheString As String, RemoveChar As String) As String
Dim Result As String
Result = TheString
While LCase(Left(Result, Len(RemoveChar))) = LCase(RemoveChar)
Result = Right(Result, Len(Result) - Len(RemoveChar))
Wend
RemoveCharFromLeftOfString = Result
End Function
Private Function RemoveBlanksAndDecsFromSubDec(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, "Public ")
Result = RemoveCharFromLeftOfString(Result, "Private ")
Result = RemoveCharFromLeftOfString(Result, " ")
RemoveBlanksAndDecsFromSubDec = Result
End Function
Private Function RemoveAsVariant(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = Replace(Result, "As Variant", "")
Result = Replace(Result, "As String", "")
Result = Replace(Result, "Function", "")
If InStr(1, Result, "( ") = 0 Then
Result = Replace(Result, "(", "( ")
End If
RemoveAsVariant = Result
End Function
Private Function IsSubroutineDeclaration(TheLine As String) As Boolean
If LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("Function "))) = "function " Or LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("sub "))) = "sub " Then
IsSubroutineDeclaration = True
End If
End Function
Private Function GetSubName(DecLine As String) As String
GetSubName = FindToRightOfString(FindToLeftOfString(DecLine, "("), " ")
End Function
Function FindToLeftOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
If ToFindPos > 0 Then
Result = Left(FullString, ToFindPos - 1)
Else
Result = FullString
End If
FindToLeftOfString = Result
End Function
Function FindToRightOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
Result = Right(FullString, Len(FullString) - ToFindPos + 1 - Len(ToFind))
If ToFindPos > 0 Then
FindToRightOfString = Result
Else
FindToRightOfString = FullString
End If
End Function