Extract text from string starting and ending by specific char - vba

I've got the code below which is extracting a string from brackets and it's ok, but now I've found out that sometimes in my string there can be more brackets with texts behind and I need to extract them too. For instance, a list or table.
e.g
hsus(irt)bla dsd (got)(rifk)
I need then: irt, got, rifk to list, how to do it?
Public Function extract_value(str As String) As String
dim str as string
dim openPos as integer
dim closePos as integer
dim midBit as string
str = "sometinhf(HELLO)sds"
openPos = instr (str, "(")
closePos = instr (str, ")")
midBit = mid (str, openPos+1, closePos - openPos - 1)
End Function

Sub Main()
Dim s$
s = "hsus(irt)bla dsd (got)(rifk)"
Debug.Print extract_value(s)
End Sub
Public Function extract_value$(s$)
Dim returnS$
Dim v
v = Split(s, Chr(40))
For Each Item In v
If InStr(Item, Chr(41)) Then
returnS = returnS & Chr(32) & Split(Item, ")")(0)
End If
Next
extract_value = Trim$(returnS)
End Function

You can use a Regexp to extract the matching strings directly
Sub Main()
Dim strTest as string
strTest = "hsus(irt)bla dsd (got)(rifk)"
MsgBox GrabIt(strTest)
End Sub
Function GrabIt(strIn As String) As String
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "\((.*?)\)"
.Global = True
If .test(strIn) Then
Set objRegMC = .Execute(strIn)
For Each objRegM In objRegMC
GrabIt = GrabIt & Chr(32) & objRegM.submatches(0)
Next
End If
End With
End Function

Related

find a complex string in a substring in VBA

how can I get in VBA a complex string in a substring, e.g. if i = InStr("test-VBA", " this is a test") then msgbox "a part of searching Item exist"
with function "Instr" didn't work because the seraching word is "test-VBA" and ofcourse dosen't
exist as a one word but what I search for if a complete part of the searching item ("test" in the
example as part of "test-VBA") exists should I get a msgbox like described above
Thanks a lot.
Function IsInStr_IgnoreCase(ByVal Str As String, ByVal Value As String) As Boolean
Dim objRegEx as Object
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.IgnoreCase = True
objRegEx.pattern = Value
IsInStr_IgnoreCase = objRegEx.test(Str) ' objRegEx.test(Str) returns True if Sustr exists.
End Function
Sub test()
' this returns TRUE if you get a match
MsgBox IsInStr_IgnoreCase_AsBoolean("CHINA-Country", "Move the dev from China to Newseeland")
' this returns all matches of 'Value' in 'Str'
MsgBox IsInStr_IgnoreCase_AsString("CHINA-Country", "Move the dev from China to Newseeland")
' you need to adjust objRegEx.Pattern if you need to get a specific match. See RegEx.
End Sub
Function IsInStr_IgnoreCase_AsBoolean(ByVal Value As String, ByVal Value As String) As Boolean
Dim objRegEx As Object
Dim tStr, tVal, iStr, iVal
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.Pattern = "(\b\w+)|(\b\d+)"
Set tStr = objRegEx.Execute(Str)
Set tVal = objRegEx.Execute(Value)
objRegEx.IgnoreCase = True
For Each iStr In tStr
For Each iVal In tVal
objRegEx.Pattern = iVal
If objRegEx.test(iStr) Then
IsInStr_IgnoreCase_AsBoolean = True
Exit Function
End If
Next
Next
End Function
Function IsInStr_IgnoreCase_AsString(ByVal Str As String, ByVal Value As String) As String
Dim objRegEx As Object
Dim tStr, tVal, iStr, iVal
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.Pattern = "(\b\w+)|(\b\d+)"
Set tStr = objRegEx.Execute(Str)
Set tVal = objRegEx.Execute(Value)
objRegEx.IgnoreCase = True
For Each iStr In tStr
For Each iVal In tVal
objRegEx.Pattern = iVal
If objRegEx.test(iStr) Then
IsInStr_IgnoreCase_AsString = IsInStr_IgnoreCase_AsString & iStr & "; "
End If
Next
Next
End Function

VBA split string sentences with multiple values

My Excel raw data looks something like this:
;123456p,Roses and butterflies;;124456h,Violets are blue;
;123456d,Hello world;
Expected output:
Roses and butterflies
Violets are blue
Hello world
Trying to split the text sentences out only, for rows with multiple sentences I would need them in
separate rows, is this at all possible? Below is what I tried.
Private Sub CommandButton1_click()
Dim splitstring As String
Dim myarray() As String
splitstring = Worksheets("raw").Cells(1, 1).Value
myarray = Split(splitstring, ";")
For i = 0 To URound(myarray)
Next
End Sub
Sub raw()
End Sub
With Regular Expressions, you can populate Column B with the desired results ae below
Option Explicit
Private Sub CommandButton1_click()
Dim wSh As Worksheet
Dim rngStr As String, rngStrArr() As String, i As Long
Set wSh = Worksheets("raw")
Dim regEx As Object, mc As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Global = True
regEx.IgnoreCase = True
rngStr = Join(Application.Transpose(Application.Index(( _
wSh.Range("A1:A" & wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row)), 0, 1)))
regEx.Pattern = ",([^;]+);"
Set mc = regEx.Execute(rngStr)
rngStr = ""
For i = 0 To mc.Count - 1
rngStr = rngStr & mc(i)
Next i
rngStr = Replace(rngStr, ",", "")
rngStrArr = Split(rngStr, ";")
wSh.Range("B1").Resize(UBound(rngStrArr), 1).Value = Application.Transpose(rngStrArr)
End Sub
Try this:
Private sub SplitString()
Dim splitstring As String
Dim myarray() As String
splitstring = Cells(1, 1).Value
myarray = Split(splitstring, ",")
For i = 1 To UBound(myarray)
MsgBox (myarray(i))
Next
End Sub

Compile Error - Argument Not Optional

I am getting error as Compile Error: Argument Not Optional when running vba code pointing towards the line. MsgBox (RemoveFirstChar)
Code:
Sub test()
Dim Currworkbook As Workbook
Dim CurrWKSHT As Worksheet
Dim Filename As String
Dim BCName As String
Dim Str As String
FFolder = "C:\user"
CurrLoc = "File3"
If CurrrLoc = "File3" Then
CurrLoc = FFolder & "\" & CurrLoc
Set FSobj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set FFolderObj = FSobj.GetFolder(CurrLoc)
If Err.Number > 0 Then
'
End If
For Each BCObj In FFolderObj.Files
'BCName = Right(BCObj.Name, (Len(BCObj.Name) - InStrRev(BCObj.Name, "\", 1)))
If IsNumeric(Left(BCObj.Name, 4)) <> True Then
Call RemoveFirstChar(BCObj.Name)
'Str = RemoveFirstChar
MsgBox (RemoveFirstChar) '--->Error: Compile Error: Argument Not Optional
Else
MsgBox (BCObj.Name)
End If
Next
End If
End Sub
Public Function RemoveFirstChar(RemFstChar As String) As String
Dim TempString As String
TempString = RemFstChar
If Left(RemFstChar, 1) = "1" Then
If Len(RemFstChar) > 1 Then
TempString = Right(RemFstChar, Len(RemFstChar) - 1)
End If
End If
RemoveFirstChar = TempString
End Function
RemoveFirstChar is a user defined function that requires a non-optional string as a parameter.
Public Function RemoveFirstChar(RemFstChar As String) As String
....
End Function
I think you want to get rid of the Call RemoveFirstChar(BCObj.Name) then use,
MsgBox RemoveFirstChar(BCObj.Name)

Delete specific lines in a text file using vb.net

I am trying to delete some specific lines of a text using VB.Net. I saw a solution here however it is in VB6. The problem is, I am not really familiar with VB6. Can somebody help me?
This is the code from the link:
Public Function DeleteLine(ByVal fName As String, ByVal LineNumber As Long) _As Boolean
'Purpose: Deletes a Line from a text file
'Parameters: fName = FullPath to File
' LineNumber = LineToDelete
'Returns: True if Successful, false otherwise
'Requires: Reference to Microsoft Scripting Runtime
'Example: DeleteLine("C:\Myfile.txt", 3)
' Deletes third line of Myfile.txt
'______________________________________________________________
Dim oFSO As New FileSystemObject
Dim oFSTR As Scripting.TextStream
Dim ret As Long
Dim lCtr As Long
Dim sTemp As String, sLine As String
Dim bLineFound As Boolean
On Error GoTo ErrorHandler
If oFSO.FileExists(fName) Then
oFSTR = oFSO.OpenTextFile(fName)
lCtr = 1
Do While Not oFSTR.AtEndOfStream
sLine = oFSTR.ReadLine
If lCtr <> LineNumber Then
sTemp = sTemp & sLine & vbCrLf
Else
bLineFound = True
End If
lCtr = lCtr + 1
Loop
oFSTR.Close()
oFSTR = oFSO.CreateTextFile(fName, True)
oFSTR.Write(sTemp)
DeleteLine = bLineFound
End If
ErrorHandler:
On Error Resume Next
oFSTR.Close()
oFSTR = Nothing
oFSO = Nothing
End Function
Dim delLine As Integer = 10
Dim lines As List(Of String) = System.IO.File.ReadAllLines("infile.txt").ToList
lines.RemoveAt(delLine - 1) ' index starts at 0
System.IO.File.WriteAllLines("outfile.txt", lines)
'This can also be the file that you read in
Dim str As String = "sdfkvjdfkjv" & vbCrLf & "dfsgkjhdfj" & vbCrLf & "dfkjbhhjsdbvcsdhjbvdhs" & vbCrLf & "dfksbvashjcvhjbc"
Dim str2() As String = str.Split(vbCrLf)
For Each s In str2
If s.Contains("YourString") Then
'add your line to txtbox
Else
'don't add your line to txtbox
End If
Next
Or You Can Use
TextFile = TextFile.Replace("You want to Delete","")

Converting String to Double in Excel / Macro

I try create new function in Excel, witch will counting given values (something like SUM function, but only with given prefix).
A
---------
1|AA30
2|AA10
3|BC446
4|AA10
// result will be 50 on SUM_PREFIX(A1:A4;"AA")
Problem is, when the value is in the form e.g AA10,434 or AA4.43. Could me anyone help me with my problem? This is my first stript in VB.
Function SUM_PREFIX(Data As Range, prefix As String) As Double
Dim result As Double
Dim strVal As String
Dim i As Integer
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.IgnoreCase = True
.MultiLine = False
.Pattern = "^[" + prefix + "]+[0-9]+(\,|\.)?[0-9]?$"
.Global = True
End With
For i = 1 To Data.Rows.Count
Debug.Print Data.Cells(i, 1)
If objRegExp.Test(Data.Cells(i, 1)) = True Then
strVal = Replace(Data.Cells(i, 1), prefix, "")
Debug.Print strVal
strVal = Trim(Replace(strVal, ",", "."))
Debug.Print strVal
result = result + CDbl(strVal)
End If
Next i
SUM_PREFIX = result
End Function
Thanks for help.
CDbl is locale-aware, so check if your Replace is correct (for example, in my locale, I have to replace "." by "," in order for it to work).
If you don't want to rely on locale-aware code, use Val instead of CDbl because Val only recognizes "." as a valid decimal separator regardless of locale.
Function SUM_PREFIXO(DADOS As Range, PREFIXO As String) As Double
Dim result, NI As Double
Dim strVal As String
Dim i As Integer
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.IgnoreCase = True
.MultiLine = False
.Pattern = "^[" + PREFIXO + "]+[0-9]+(\,|\.)?[0-9]?$"
.Global = True
End With
NI = DADOS.Rows.Count
For i = 1 To DADOS.Rows.Count
Debug.Print (DADOS.Cells(i, 1))
If objRegExp.Test(RetiraEspaço(DADOS.Cells(i, 1))) = True Then
strVal = Trim(Replace(DADOS.Cells(i, 1), PREFIXO, ""))
Debug.Print strVal
strVal = Trim(Replace(strVal, ".", ","))
Debug.Print strVal
strVal = Trim(Replace(strVal, ",", ","))
Debug.Print strVal
result = result + CDbl(strVal)
End If
Next i
SUM_PREFIXO = result
End Function
'Com o código abaixo pode-se
'remover os espaços extras entre as palavras de um texto:
Function RetiraEspaço(Texto)
Dim Vpalavra, inicio, termino, Wresultado
inicio = 1
Texto = UCase(Texto) & " "
Do Until InStr(inicio, Texto, " ") = 0
termino = InStr(inicio, Texto, " ")
Vpalavra = Mid(Texto, inicio, termino - inicio)
inicio = termino + 1
Wresultado = Wresultado & "" & Vpalavra
Loop
RetiraEspaço = Trim(Wresultado)
End Function