I have a simple function to get data:
Function GetAppro(Current_Sheet As String)
Dim myArray As Variant
myArray = Worksheets(Current_Sheet).Range("A3:C6")
GetAppro = myArray
End Function
And other funtion to get other data:
Function GetTabs()
Dim Get_Tabs_generated(2) As String
Get_Tabs_generated(0) = "AA"
Get_Tabs_generated(1) = "BB"
Get_Tabs_generated(2) = "CC"
GetTabs = Get_Tabs_generated
End Function
In my final procedure i do:
Sub GenerateDB()
Dim Appro() As String
Dim Tabs() As String
'Init
Tabs = GetTabs()
For Each Tabs_item In Tabs
Appro = GetAppro(Tabs_item.Value)
MsgBox Appro(0, 0)
Next Tabs_item
End Sub
Excel say me compile error Object required (Error 424). I am novice with functions
Solution:
Do not forget CStr()
Sub GenerateDB()
Dim Appro() As String
Dim Tabs() As String
'Init
Tabs = GetTabs()
For Each Tabs_item In Tabs
Appro = GetAppro(CStr(Tabs_item))
MsgBox Appro(0, 0)
Next Tabs_item
End Sub
Special thanks to #ScottCraner
Related
I am trying to create an excel function which will fill column with data gathered from OGame's reports. I have encountered strage behavior (at least from my point of view).
I have a form where the user can copy their reports to a form's textbox. After clicking the button, the following functions should start:
Option Explicit
Private Sub CommandButton1_Click()
Dim arr() As String
Dim test As Boolean
Dim str As String
str = testFunction()
arr = readData(Raporty.Value)
' Dim element As Variant
' For Each element In arr
' Debug.Print element
' Debug.Print "-------------------------------"
' Next element
test = writeData(arr)
Debug.Print (test)
Debug.Print ("str: " + str)
Unload ufWczytajRaporty
End Sub
Private Function testFunction() As String
Debug.Print ("testFunction")
testFunction = "testFunctionText"
End Function
Private Function writeData(arr1() As String) As Boolean
Debug.Print ("writeData")
For Each element In arr1
writeDataRow (element)
Next element
writeData = True
End Function
Private Function readData(text As String) As String()
Debug.Print ("readData")
Dim list As Object
Dim substr As Integer
Dim temp As String
Dim arr(0 To 10) As String
Dim result() As String
Dim counter As Integer
Set list = CreateObject("System.Collections.ArrayList")
counter = 0
If text = "" Then
MsgBox "Dane nie mogą być puste! Proszę uzupełnić poprawnymi raportami!", vbCritical
Else
If InStr(1, text, "Przybył statek handlowy") = 1 Then
While (InStr(1, text, "Towar został już odebrany."))
substr = InStr(1, text, "Towar został już odebrany.") + 26
arr(counter) = Left(text, substr)
temp = Mid(text, substr, Len(text))
text = temp
counter = counter + 1
Wend
Unload ufWczytajRaporty
Else
MsgBox "Niepoprawne raporty! Proszę wkleć dobre raporty!", vbCritical
End If
End If
ReDim result(0 To counter)
Dim i As Integer
For i = 0 To counter
result(i) = arr(i)
Next i
readData = arr
End Function
This functions provide the following result in Immediate:
testFunction
readData
False
str: testFunctionText
As you can see the above false is a call of writeData fuction, however it never entered the function. writeData function contains Debug.Print ("writeData") but it was never displayed.
Furthermore if I change places the following function:
str = testFunction()
arr = readData(Raporty.Value)
to
arr = readData(Raporty.Value)
str = testFunction()
testFunction is not called aswell.
Can someone explain me what is happening? Why those functions are not called?
I have a simple Function to get and save values in array:
Function GetDataOwner()
Dim DataOwner(2) As String
DataOwner(0) = Sheets(1).Range("H21").Value
DataOwner(1) = Sheets(1).Range("I21").Value
DataOwner(2) = Sheets(1).Range("J21").Value
End Function
In other function, I would like read value:
Sub GenerateDB()
Dim DataOwner() As String
DataOwner = GetDataOwner()
MsgBox DataOwner(1)
End Sub
But Excel say me error 13 type mismatch. I am novice with VBA function
Soluce:
Function GetDataOwner()
Dim DataOwner(2) As String
DataOwner(0) = Sheets(1).Range("H21").Value
DataOwner(1) = Sheets(1).Range("I21").Value
DataOwner(2) = Sheets(1).Range("J21").Value
GetDataOwner = DataOwner
End Function
Sub GenerateDB()
Dim DataOwner() As String
DataOwner = GetDataOwner()
MsgBox DataOwner(1)
End Sub
Thanks to #Comintern
Currently I'm using InStr to find a string in a string, I'm new to VB.NET and wondering if I can use InStr to search every element of an array in a string, or a similar function like this:
InStr(string, array)
Thanks.
You need to loop:
Dim bFound As Boolean = False
For Each elem As String In array
If myString.Contains(elem) Then
bFound = True
Exit For
End If
Next
You can transform it into a function to call it more than once easily:
Public Function MyInStr(myString As String, array() As String) As Boolean
For Each elem As String In array
If myString.Contains(elem) Then return True
Next
return false
End Function
Then:
MyInStr("my string text", New String() {"my", "blah", "bleh"})
Here goes the LINQ solution:
Dim a() = {"123", "321", "132"}
Dim v = a.Select(Function(x) InStr(x, "3")).ToArray
MessageBox.Show(String.Join(",", v)) '3,1,2
Converting SysDragon's answer to classic asp:
You need to loop:
Dim bFound
bFound = False
For Each elem In myArray
If InStr(myString, elem)>=0 Then
bFound = True
Exit For
End If
Next
You can transform it into a function to call it more than once easily:
Function MyInStr(myString, myArray)
Dim bFound
bFound = false
For Each elem In myArray
If InStr(myString, elem)>=0 Then
bFound = True
Exit For
End If
Next
MyInStr = bFound
End Function
Then:
MyInStr("my string text", Array("my", "blah", "bleh"))
If you are looking at searching for a string in any of the items in a string array, then you can use array.find(<T>) method. See more here: http://msdn.microsoft.com/en-IN/library/d9hy2xwa%28v=vs.90%29.aspx
Instr returns an integer specifying the start position of the first occurrence of one string within another.
Refer this
To find string in a string you can use someother method
Here is an example of highlighting all the text you search for at the same time but if that is not what you want, you have to solve it on your own.
Sub findTextAndHighlight(ByVal searchtext As String, ByVal rtb As RichTextBox)
Dim textEnd As Integer = rtb.TextLength
Dim index As Integer = 0
Dim fnt As Font = New Font(rtb.Font, FontStyle.Bold)
Dim lastIndex As Integer = rtb.Text.LastIndexOf(searchtext)
While (index < lastIndex)
rtb.Find(searchtext, index, textEnd, RichTextBoxFinds.WholeWord)
rtb.SelectionFont = fnt
rtb.SelectionLength = searchtext.Length
rtb.SelectionColor = Color.Red
rtb.SelectionBackColor = Color.Cyan
index = rtb.Text.IndexOf(searchtext, index) + 1
End While
End Sub
This method with search for text "boy" in RichTextBox2, change the textcolor to red and back color to cyan
Private Sub Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button5.Click
findTextAndHighlight("boy", RichTextBox2)
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