I want to search for more than one string in a file with vb6
using instr we can do it for single string but I don't know how to use instr for more than one string now how can I search for more than one and if find one of them we receive a message?
Open file For Binary As #1
strData = Space$(FileLen(file))
Get #1, , strData
Close #1
lngFind = InStr(1, strData, string)
That's simply a case of introducing multiple tests for multiple strings...
Dim strArray(10) As String
DIm cntArray(10) As Integer
Dim strData As String
Dim c As Integer
'Set-up your search strings...
...
Open file For Binary As #1
Get #1, , strData
Close #1
For c = 1 to 10
cntArray(c) = Instr(strData, strArray(c))
Next c
If all you want to do is show a true or false message box then we don't need to assign the value to the second array. The For loop could be replaced with...
For c = 1 to 10
If Instr(strData, strArray(c)) > 0 Then
MsgBox "'" & strArray(c) & "' found in file."
'Remove the following line if you want everything to be searched for,
'but leave it in if you only want the first string found...
Exit For
End If
Next c
Really this is a very basic piece of code. If you're looking to write code as anything but a novice then you need to research the commands, functions and structures included in this post. A good place to start, for a complete novice, would be somewhere like http://www.thevbprogrammer.com/classic_vbtutorials.asp or http://www.vb6.us/.
'-----------------------------------------------------------
'perform multiple instr on a string. returns true if all instr pass
'-----------------------------------------------------------
Function bMultiInstr(sToInspect As String, ParamArray sArrConditions()) As Boolean
On Error GoTo err:
Dim i As Integer, iUpp As Integer
iUpp = UBound(sArrConditions) 'instr conditions
For i = 0 To iUpp ' loop them
If InStr(1, sToInspect, sArrConditions(i)) <= 0 Then Exit Function ' if instr returns 0 then exit - [bPasses] will be left false
Next i
bPasses = True
Exit Function
err:
With err
If .Number <> 0 Then
'create .bas named [ErrHandler] see http://vb6.info/h764u
ErrHandler.ReportError Date & ": Strings.bMultiInstr." & err.Number & "." & err.Description
Resume Next
End If
End With
End Function
That is from http://vb6.info/string/instr-multi-perform-instr-checks-multiple-inst-conditions-function/
Related
Using Excel VBA: Is it possibile to get the text contained in the tooltip which shows the argument list of a sub or function?
The Application.MacroOptions method knows the argument "ArgumentDescriptions" but it is possibly only set. Is there any way to read this info?
"Get the tooltip text contained showing the argument list of a sub or function ... The Application.MacroOptions Method has (the) argument ArgumentDescriptions but it Is possibile(!) only set. Is there any way to read this info?"
► Afaik there is no built-in way.
Possible workaround
As you "need this info in VBA code for a function/sub created in other module or class.",
you might want to analyze your code modules by referencing the
"Microsoft Visual Basic for Applications Extensibility 5.3" library in the VB Editor's menu.
Caveats:
Security: Requires to trust access to the VBA project object model.
Rights: If not only for your personal use, consider that other corporate users may
not have enough rights to turn that feature on.
Self reflection: Mirrors the currently compiled/saved code only, so it might not reflect the latest code when the searched procedure body line has been changed.
Line breaks: The following approach assumes that the entire procedure info is coded in one line -
not regarding closing line breaks via "_";
it should be easy to extend the .Lines result in these cases by your own (e.g. benefitting from the count argument or by additional loops through the next lines).
The following code doesn't intend neither to cover or to optimize all possibilities,
but to direct you to a solution keeping it short & simple.
Function GetSyntax()
Function GetSyntax(wb As Workbook, Optional ByVal srchProcName As String = "GetCookie") As String
'Purp: Show name & arguments of a given procedure
'1) escape a locked project
If wb.VBProject.Protection = vbext_pp_locked Then Exit Function ' escape locked projects
'2) loop through all modules
Dim component As VBIDE.VBComponent
For Each component In wb.VBProject.VBComponents
' Debug.Print "***"; component.Name, component.Type
Dim found As Boolean
'3) loop through procedures (as well as Let/Set/Get properties)
Dim pk As Long ' proc kind enumeration
For pk = vbext_pk_Proc To vbext_pk_Get
'a) get the essential body line of the search procedure
Dim lin As String
lin = getLine(component.CodeModule, srchProcName, pk)
'b) found non-empty code line?
found = Len(lin) <> 0
If found And pk = 0 Then GetArgs = lin: Exit For
'c) get proc info(s) - in case of Let/Set/Get properties
Dim Delim As String
GetSyntax = GetSyntax & IIf(found, Delim & lin, "")
Delim = vbNewLine ' don't change line order
Next pk
'If found Then Exit For ' if unique proc names only
Next component
End Function
Help function getLine()
Function getLine(module As VBIDE.CodeModule, ByVal srchProcName As String, ByVal pk As Long) As String
'a) define procedure kind
Dim ProcKind As VBIDE.vbext_ProcKind
ProcKind = pk
'b) get effective row number of proc/prop body line
On Error Resume Next
Dim effectiveRow As Long
effectiveRow = module.ProcBodyLine(srchProcName, ProcKind) ' find effective row of search procedure
'c) provide for non-findings or return function result (Case 0)
Select Case Err.Number
Case 0 ' Found
Dim lin As String
'Syntax: obj.Lines (startline, count) As String
lin = Trim(module.Lines(effectiveRow, 1))
getLine = lin
Case 35 ' Not found
Err.Clear: On Error GoTo 0
Case Else
Debug.Print "** " & " Error " & Err.Number & " " & Err.Description: Err.Clear: On Error GoTo 0
End Select
End Function
Possible Test call
Dim procList, proc
procList = Split("getCookie,foo,myNewFunction", ",")
For Each proc In procList
MsgBox GetSyntax(ThisWorkbook, proc), vbInformation, proc
Next
Translate formula quotation marks incl. replacements into VBA-readable formulae
I was inspired to write this post by the recent question of
formula substitution using a constant.
At the same time, the frequent problem emerged that quotation marks
within a formula string should be replaced by double quotation marks in order
to make them readable in VBA.
Practical use case
A practical use case is to copy a table formula directly from a SO website
and "translate" it into a string-readable format.
But how is this supposed to be done with VBA means, since the direct input of
such an incomplete formula string in a procedure code without manually
added double quotation marks would immediately lead to an error?
Another feature would be to make replacements at certain points within
a formula template, for example with a constant or even with several
numerically identifiable markers.
I found a quick & dirty solution (without error handling) by analyzing a FormulaContainer procedure containing
exclusively outcommented formulae as these would allow any prior direct code input.
In order to distinguish them from the usual commentaries,
I decided with a heavy heart to use the Rem prefix (i.e. Remark) as an alternative, which we may still be familiar with from ancient Basic times.
My intention is not to show a perfect solution, but to stimulate further solutions
by demonstrating a possible way.
Question
Are there other work arounds allowing to copy tabular formulae with quotation marks directly and as possible replacement pattern into VBA procedures?
///////////////////////////////////
Main function QuickFormula()
References a FormulaContainer procedure containing exclusively formulae with Rem prefixes, such as e.g.
Sub FormulaContainer()
Rem =....
Rem =....
End Sub
This allows formula inputs with quotation marks similar to tabular cell inputs;
furthermore these inputs may contain string identifiers facilitating wanted replacements.
Option Explicit
'Site: https://stackoverflow.com/questions/70399681/how-many-quotes-to-put-around-a-formula-that-is-sending-an-empty-string
'Auth: https://stackoverflow.com/users/6460297/t-m
Function QuickFormula(ByVal no As Long, ParamArray repl() As Variant) As String
'Purp: - change indicated code line in FormulaContainer to code readable string and
' - replace enumerated identifiers with given value(s)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'1) get REMark code line indicated by ordinal argument no
QuickFormula = getCodeLine("modFormula", "FormulaContainer", no)
'2a)replace "#" identifyer(s) with constant repl value
If Not IsArray(repl(0)) Then
QuickFormula = Replace(QuickFormula, "{1}", "#")
QuickFormula = Replace(QuickFormula, "#", repl(0))
If Len(QuickFormula) = 0 Then QuickFormula = "Error NA!"
Debug.Print no & " ~~> " & Chr(34) & QuickFormula & Chr(34)
Exit Function
End If
'2b)replace 1-based "{i}" identifiers by ParamArray values
Dim i As Long
For i = LBound(repl(0)) To UBound(repl(0))
QuickFormula = Replace(QuickFormula, "{" & i + 1 & "}", repl(0)(i))
Next
'3) optional display in immediate window
Debug.Print no & " ~~> " & Chr(34) & QuickFormula & Chr(34)
End Function
Help function getCodeLine()
Gets a given code line of the indicated procedure
Function getCodeLine(ByVal ModuleName As String, ByVal ProcedureName As String, Optional ByVal no As Long = 1) As String
'Purp: return a code line in given procedure containing "Rem "
'Note: assumes no line breaks; needs a library reference to
' "Microsoft Visual Basic for Applications Extensibility 5.3"
Const SEARCH As String = "Rem =", QUOT As String = """"
'1) set project
Dim VBProj As Object
Set VBProj = ThisWorkbook.VBProject
If VBProj.Protection = vbext_pp_locked Then Exit Function ' escape locked projects
'2) set component
Dim VBComp As Object
Set VBComp = VBProj.VBComponents(ModuleName)
Dim pk As vbext_ProcKind
'3) get no + 3 top code line(s)
With VBComp.CodeModule
'a)count procedure header lines
Dim HeaderCount As Long: HeaderCount = .ProcBodyLine(ProcedureName, pk) - .ProcStartLine(ProcedureName, pk)
'b) get procedure code
Dim codelines
'codelines = Split(.Lines(.ProcBodyLine(ProcedureName, pk), .ProcCountLines(ProcedureName, pk) - HeaderCount), vbNewLine)
codelines = Split(.Lines(.ProcBodyLine(ProcedureName, pk), no + 1), vbNewLine)
'c) filter code lines containing "Rem" entries
codelines = Filter(codelines, SEARCH, True)
End With
'4) return (existing) codeline no
If no - 1 > UBound(codelines) Then Exit Function ' check existance
getCodeLine = Replace(Replace(codelines(no - 1), QUOT, String(2, QUOT)), "Rem =", "=")
End Function
Example call
References all three formulae in the FormulaContainer (including an example of a non-existing number):
Sub EnterFormula()
With Sheet1.Range("X1") ' << change to any wanted target range
.Offset(1).Formula2 = QuickFormula(1, 6)
.Offset(2).Formula2 = QuickFormula(2, Array(10, 20, 30))
'two single argument inputs with same result
.Offset(3).Formula2 = QuickFormula(3, Array(17))
.Offset(4).Formula2 = QuickFormula(3, 17)
'not existing formula number in Rem code container
.Offset(5).Formula2 = QuickFormula(333, 17)
End With
End Sub
Example FormulaContainer
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Purp: formula container to be adjusted to code readable strings
'Note: Insert only Formulae starting with "Rem "-prefix!
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' # identifies constant replacement(s)
' {i} stands for enumerated replacements {1},{2}..{n}
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub FormulaContainer()
Rem =IF($V#>0,IF($G#>$S#,($S#-$H#)*$K#+$Y#,($G#-$H#)*$K#+$Y#),"")
Rem =A{1}*B{3}+C{2}
Rem =A{1}+100
End Sub
Example output in immediate window
1 ~~> "=IF($V6>0,IF($G6>$S6,($S6-$H6)*$K6+$Y6,($G6-$H6)*$K6+$Y6),"""")"
2 ~~> "=A10*B30+C20"
3 ~~> "=A17+100"
3 ~~> "=A17+100"
333 ~~> "Error NA!"
Keep it simple stupid
Assuming either the currently selected cell formula or a textbox input, a simple Userform might act as a formula translator into a line of VBA code:
Basic Userform code
Needed: TextBox1, TextBox2, CommandButton1
Option Explicit
Private Sub CommandButton1_Click()
'Purp: Redouble inside quotation marks
Const Quot As String = """"
Dim assignTo As String
assignTo = "ws.Range(""" & Selection.Address(False, False) & """).Formula2 = "
Me.TextBox2.Text = assignTo & Quot & Replace(Me.TextBox1.Text, Quot, String(2, Quot)) & Quot
End Sub
Private Sub UserForm_Initialize()
'Purp: assume active formula as wanted input
Me.TextBox1 = Selection.Formula2
End Sub
Private Sub UserForm_Layout()
'Purp: example layout textboxes
'a) define textboxes
Dim textboxes() As String
textboxes = Split("Textbox1,Textbox2", ",")
'b) format
Dim i As Long
For i = 0 To UBound(textboxes)
With Me.Controls(textboxes(i))
.Font.Name = "Courier New"
.Font.Size = 12
.MultiLine = True
.EnterKeyBehavior = True
End With
Next i
End Sub
Possible extensions
Of course you might add an insertion routine (inserting e.g. {} brackets) as well as some replacement procedures like in my workaround above.
Just for fun, a basic insertion routine here:
Private Sub CommandButton2_Click()
'Purp: Insert brackets {}
With Me.TextBox1
.SetFocus
If InsertAtCursor("{}", Me.TextBox1) Then
.SelStart = .SelStart - 1
End If
End With
End Sub
Public Function InsertAtCursor(s As String, ctrl As MSForms.Control, Optional ErrMsg As String) As Boolean
'Purpose: Insert the characters at the cursor in the active control.
'Site: http://allenbrowne.com/func-InsertChar.html
'Return: True if characters were inserted.
'Arguments: s = the character(s) you want inserted at the cursor.
' ErrMsg = string to append any error messages to.
'Note: Control must have focus.
On Error GoTo Err_Handler
Dim prior As String 'Text before the cursor.
Dim after As String 'Text after the cursor.
Dim cnt As Long 'Number of characters
Dim iSelStart As Long 'Where cursor is.
Dim txt As String 'text with LineFeeds only
If s <> vbNullString Then
With ctrl ' --> UserForm Control
txt = Replace(.Text, vbCrLf, vbLf) ' LineFeeds only (MultiLine)
If .Enabled And Not .Locked Then
cnt = Len(txt) ' Zählung ohne vbCr's !
'SelStart can't cope with more than 32k characters.
If cnt <= 32767& - Len(s) Then
'Remember characters before cursor.
iSelStart = .SelStart
If iSelStart > 1 Then
prior = Left$(txt, iSelStart)
End If
'Remember characters after selection.
If iSelStart + .SelLength < cnt Then
after = Mid$(txt, iSelStart + .SelLength + 1) ' OP:2
End If
'Assign prior characters, new ones, and later ones.
.value = prior & s & after
'Put the cursor back where it as, after the new ones.
.SelStart = iSelStart + Len(s)
'Return True on success
InsertAtCursor = True
End If
End If
End With
End If
Exit_Handler:
Exit Function
Err_Handler:
Debug.Print Err.Number, Err.Description
Select Case Err.Number
Case 438&, 2135&, 2144& 'Object doesn't support this property. Property is read-only. Wrong data type.
ErrMsg = ErrMsg & "You cannot insert text here." & vbCrLf
Case 2474&, 2185& 'No active control. Control doesn't have focus.
ErrMsg = ErrMsg & "Cannot determine which control to insert the characters into." & vbCrLf
Case Else
ErrMsg = ErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf
End Select
Resume Exit_Handler
End Function
I am attempting to work on a code which will allow me to check two lines of all my text files in a folder.
Each text file will be structured like so:
NS1234 <--- A random reference number on the first line
Approve < Reject or Approve on the second line
At the moment the code only reads one text file which I specify the name of, however I want it to scan all .txt files.
Next, When I open my spread sheet I will have the following set-up:
Column A Column
NS1234
I want my code to scan all text files to check for any matching reference number from column A against all the text files.
And then where a match is found insert either 'Approve' or 'Reject', where this is written on the second line of the text file, into the corresponding row in column s
Code:
Public Sub test()
Dim fn As Integer
fn = FreeFile
Open "Z:\NS\Approval\NS32D1QR.txt" For Input As fn
Dim wholeFile As String
wholeFile = Input(LOF(fn), #fn)
Close #fn
Dim splitArray
splitArray = Split(wholeFile, vbCrLf)
Dim lineNum As Integer
lineNum = 2
Dim i As Integer, intValueToFind As Integer
intValueToFind = NS32D1QR
For i = 1 To 500 ' Revise the 500 to include all of your values
If Cells(i, 1).Value = intValueToFind And splitArray(lineNum - 1) = "Approve" Then
Range("S" & ActiveCell.Row).Value = "Approve"
End If
Next i
End Sub
i 'm not sure about the test that you made in your loop but it seems to me that the info where on the 2 first lines so no use to loop or to use special variables there. Let me know if this work properly or not! ;)
Here is a sub to test, as it is a function you can either loop on it or use it in Excel workbook.
Sub test()
With Sheets("Sheet1")
For i = 2 To .Rows(.Rows.Count).End(xlUp).Row
.Cells(i, "S") = Get_AorP(.Cells(i, "A"))
Next i
End With
End Sub
Here is what you wanted to do, converted to a function :
Public Function Get_AorP(ByVal Value_to_Find As String) As String
Dim fn As Integer, _
Txts_Folder_Path As String, _
File_Name As String, _
wholeFile As String, _
splitArray() As String, _
i As Integer
On Error GoTo ErrHandler
Txts_Folder_Path = "Z:\NS\Approval\"
File_Name = Dir(Txts_Folder_Path & "*.txt")
While File_Name <> vbNullString
fn = FreeFile
Open Txts_Folder_Path & File_Name For Input As fn
wholeFile = Input(LOF(fn), #fn)
Close #fn
MsgBox File_Name
splitArray = Split(wholeFile, vbCrLf)
If UBound(splitArray) < 2 Or LBound(splitArray) > 1 Then
'avoid empty text files
Else
If InStr(1, splitArray(0), Value_to_Find) <> 0 Then
If InStr(1, splitArray(1), "Approve") Then
Get_AorP = "Approve"
Exit Function
Else
If InStr(1, splitArray(1), "Reject") Then
Get_AorP = "Reject"
Exit Function
Else
'Nothing to do
End If
End If
Else
'not the good value
End If
End If
File_Name = Dir()
Wend
Get_AorP = "No matches found"
Exit Function
ErrHandler:
Get_AorP = "Error during the import." & vbCrLf & Err.Number & " : " & Err.Description
End Function
I have one text file that contains around 100K lines. Now I would like to search a string from the text file. If that string is present then I want to get the line number at which it's present. At the end I need all the occurrence of that string with line numbers from the text file.
* Ordinary Method Tried *
We can read the whole text file line by line. Keep a counter variable that increases after every read. If I found my string then I will return the Counter Variable. The limitation of this method is, I have to traverse through all the 100K lines one by one to search the string. This will decrease the performance.
* Quick Method (HELP REQUIRED)*
Is there any way that will directly take me to the line where my searchstring is present and if found I can return the line number where it's present.
* Example *
Consider below data is present in text file. (say only 5 lines are present)
Now I would like to search a string say "Pune". Now after search, it should return me Line number where string "pune" is present. Here in this case it's present in line 2. I should get "2" as an output. I would like to search all the occurrence of "pune" with their line numbers
I used a spin off of Me How's code example to go through a list of ~10,000 files searching for a string. Plus, since my html files have the potential to contain the string on several lines, and I wanted a staggered output, I changed it up a bit and added the cell insertion piece. I'm just learning, but this did exactly what I needed and I hope it can help others.
Public Sub ReadTxtFile()
Dim start As Date
start = Now
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oFS As Object
Dim filePath As String
Dim a, b, c, d, e As Integer
a = 2
b = 2
c = 3
d = 2
e = 1
Dim arr() As String
Do While Cells(d, e) <> vbNullString
filePath = Cells(d, e)
ReDim arr(5000) As String
Dim i As Long
i = 0
If oFSO.FileExists(filePath) Then
On Error GoTo Err
Set oFS = oFSO.OpenTextFile(filePath)
Do While Not oFS.AtEndOfStream
arr(i) = oFS.ReadLine
i = i + 1
Loop
oFS.Close
Else
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
For i = LBound(arr) To UBound(arr)
If InStr(1, arr(i), "Clipboard", vbTextCompare) Then
Debug.Print i + 1, arr(i)
Cells(a + 1, b - 1).Select
Selection.Insert Shift:=xlDown
Cells(a, b).Value = i + 1
Cells(a, c).Value = arr(i)
a = a + 1
d = d + 1
End If
Next
a = a + 1
d = d + 1
Loop
Debug.Print DateDiff("s", start, Now)
Exit Sub
Err:
MsgBox "Error while reading the file.", vbCritical, vbNullString
oFS.Close
Exit Sub
End Sub
the following fragment could be repalaced like:
Dim arr() As String
Dim i As Long
i = 0
If oFSO.FileExists(filePath) Then
On Error GoTo Err
Set oFS = oFSO.OpenTextFile(filePath)
Do While Not oFS.AtEndOfStream
ReDim Preserve arr(0 To i)
arr(i) = oFS.ReadLine 'to save line's content to array
'If Len(oFSfile.ReadLine) = 0 Then Exit Do 'to get number of lines only
i = i + 1
Loop
oFS.Close
Else
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
Here's another method that should work fairly quickly. It uses the shell to execute the FINDSTR command. If you find the cmd box flickers, do an internet search for how to disable it. There are two options provided: one will return the line number followed by a colon and the text of the line containing the keyword. The other will just return the line number.
Not sure what you want to do with the results, so I just have them in a message box.
Option Explicit
'Set reference to Windows Script Host Object Model
Sub FindStrings()
Const FindStr As String = "Pune"
Const FN As String = "C:\users\ron\desktop\LineNumTest.txt"
Dim WSH As WshShell
Dim StdOut As Object
Dim S As String
Set WSH = New WshShell
Set StdOut = WSH.Exec("cmd /c findstr /N " & FindStr & Space(1) & FN).StdOut
Do Until StdOut.AtEndOfStream
S = S & vbCrLf & StdOut.ReadLine
'If you want ONLY the line number, then
'S = S & vbCrLf & Split(StdOut.ReadLine, ":")(0)
Loop
S = Mid(S, 2)
MsgBox (S)
End Sub
I need to convert a string, obtained from excel, in VBA to an interger. To do so I'm using CInt() which works well. However there is a chance that the string could be something other than a number, in this case I need to set the integer to 0. Currently I have:
If oXLSheet2.Cells(4, 6).Value <> "example string" Then
currentLoad = CInt(oXLSheet2.Cells(4, 6).Value)
Else
currentLoad = 0
End If
The problem is that I cannot predict all possible non numeric strings which could be in this cell. Is there a way I can tell it to convert if it's an integer and set to 0 if not?
Use IsNumeric. It returns true if it's a number or false otherwise.
Public Sub NumTest()
On Error GoTo MyErrorHandler
Dim myVar As Variant
myVar = 11.2 'Or whatever
Dim finalNumber As Integer
If IsNumeric(myVar) Then
finalNumber = CInt(myVar)
Else
finalNumber = 0
End If
Exit Sub
MyErrorHandler:
MsgBox "NumTest" & vbCrLf & vbCrLf & "Err = " & Err.Number & _
vbCrLf & "Description: " & Err.Description
End Sub
Cast to long or cast to int, be aware of the following.
These functions are one of the view functions in Excel VBA that are depending on the system regional settings. So if you use a comma in your double like in some countries in Europe, you will experience an error in the US.
E.g., in european excel-version 0,5 will perform well with CDbl(), but in US-version it will result in 5.
So I recommend to use the following alternative:
Public Function CastLong(var As Variant)
' replace , by .
var = Replace(var, ",", ".")
Dim l As Long
On Error Resume Next
l = Round(Val(var))
' if error occurs, l will be 0
CastLong = l
End Function
' similar function for cast-int, you can add minimum and maximum value if you like
' to prevent that value is too high or too low.
Public Function CastInt(var As Variant)
' replace , by .
var = Replace(var, ",", ".")
Dim i As Integer
On Error Resume Next
i = Round(Val(var))
' if error occurs, i will be 0
CastInt = i
End Function
Of course you can also think of cases where people use commas and dots, e.g., three-thousand as 3,000.00. If you require functionality for these kind of cases, then you have to check for another solution.
Try this:
currentLoad = ConvertToLongInteger(oXLSheet2.Cells(4, 6).Value)
with this function:
Function ConvertToLongInteger(ByVal stValue As String) As Long
On Error GoTo ConversionFailureHandler
ConvertToLongInteger = CLng(stValue) 'TRY to convert to an Integer value
Exit Function 'If we reach this point, then we succeeded so exit
ConversionFailureHandler:
'IF we've reached this point, then we did not succeed in conversion
'If the error is type-mismatch, clear the error and return numeric 0 from the function
'Otherwise, disable the error handler, and re-run the code to allow the system to
'display the error
If Err.Number = 13 Then 'error # 13 is Type mismatch
Err.Clear
ConvertToLongInteger = 0
Exit Function
Else
On Error GoTo 0
Resume
End If
End Function
I chose Long (Integer) instead of simply Integer because the min/max size of an Integer in VBA is crummy (min: -32768, max:+32767). It's common to have an integer outside of that range in spreadsheet operations.
The above code can be modified to handle conversion from string to-Integers, to-Currency (using CCur() ), to-Decimal (using CDec() ), to-Double (using CDbl() ), etc. Just replace the conversion function itself (CLng). Change the function return type, and rename all occurrences of the function variable to make everything consistent.
Just use Val():
currentLoad = Int(Val([f4]))
Now currentLoad has a integer value, zero if [f4] is not numeric.
To put it on one line:
currentLoad = IIf(IsNumeric(oXLSheet2.Cells(4, 6).Value), CInt(oXLSheet2.Cells(4, 6).Value), 0)
Here are a three functions that might be useful. First checks the string for a proper numeric format, second and third function converts a string to Long or Double.
Function IsValidNumericEntry(MyString As String) As Boolean
'********************************************************************************
'This function checks the string entry to make sure that valid digits are in the string.
'It checks to make sure the + and - are the first character if entered and no duplicates.
'Valid charcters are 0 - 9, + - and the .
'********************************************************************************
Dim ValidEntry As Boolean
Dim CharCode As Integer
Dim ValidDigit As Boolean
Dim ValidPlus As Boolean
Dim ValidMinus As Boolean
Dim ValidDecimal As Boolean
Dim ErrMsg As String
ValidDigit = False
ValidPlus = False
ValidMinus = False
ValidDecimal = False
ValidEntry = True
For x = 1 To Len(MyString)
CharCode = Asc(Mid(MyString, x, 1))
Select Case CharCode
Case 48 To 57 ' Digits 0 - 9
ValidDigit = True
Case 43 ' Plus sign
If ValidPlus Then 'One has already been detected and this is a duplicate
ErrMsg = "Invalid entry....too many plus signs!"
ValidEntry = False
Exit For
ElseIf x = 1 Then 'if in the first positon it is valide
ValidPlus = True
Else 'Not in first position and it is invalid
ErrMsg = "Invalide entry....Plus sign not in the correct position! "
ValidEntry = False
Exit For
End If
Case 45 ' Minus sign
If ValidMinus Then 'One has already been detected and this is a duplicate
ErrMsg = "Invalide entry....too many minus signs! "
ValidEntry = False
Exit For
ElseIf x = 1 Then 'if in the first position it is valid
ValidMinus = True
Else 'Not in first position and it is invalid
ErrMsg = "Invalide entry....Minus sign not in the correct position! "
ValidEntry = False
Exit For
End If
Case 46 ' Period
If ValidDecimal Then 'One has already been detected and this is a duplicate
ErrMsg = "Invalide entry....too many decimals!"
ValidEntry = False
Exit For
Else
ValidDecimal = True
End If
Case Else
ErrMsg = "Invalid numerical entry....Only digits 0-9 and the . + - characters are valid!"
ValidEntry = False
Exit For
End Select
Next
If ValidEntry And ValidDigit Then
IsValidNumericEntry = True
Else
If ValidDigit = False Then
ErrMsg = "Text string contains an invalid numeric format." & vbCrLf _
& "Use only one of the following formats!" & vbCrLf _
& "(+dd.dd -dd.dd +dd -dd dd.d or dd)! "
End If
MsgBox (ErrMsg & vbCrLf & vbCrLf & "You Entered: " & MyString)
IsValidNumericEntry = False
End If
End Function
Function ConvertToLong(stringVal As String) As Long
'Assumes the user has verified the string contains a valide numeric entry.
'User should call the function IsValidNumericEntry first especially after any user input
'to verify that the user has entered a proper number.
ConvertToLong = CLng(stringVal)
End Function
Function ConvertToDouble(stringVal As String) As Double
'Assumes the user has verified the string contains a valide numeric entry.
'User should call the function IsValidNumericEntry first especially after any user input
'to verify that the user has entered a proper number.
ConvertToDouble = CDbl(stringVal)
End Function