I am using following codes repeatedly. Is there any better alternative.
Dim strtxt as string
strtxt = Replace(strtxt, "String1", "")
strtxt = Replace(strtxt, "String2", "")
strtxt = Replace(strtxt, "String3", "")
strtxt = Replace(strtxt, "String4", "")
strtxt = Replace(strtxt, "String5", "")
strtxt = Replace(strtxt, "String6", "")
strtxt = Replace(strtxt, "String7", "")
Try this
Dim mLBound As Long
Dim mUBound As Long
Dim mSize As Long
Dim result As String
Dim RepChars As Variant
RepChars = Array("a", "b", "c")
mLBound = LBound(RepChars)
mUBound = UBound(RepChars)
result = Range("A2").Value
For mSize = mLBound To mUBound
result = Replace(result, CStr(RepChars(mSize)), "")
Next
Range("A3").Value = result
Or the Regex could be used. Example based on this answer.
Option Explicit
Sub ReplaceWithRegex()
Dim strPattern As String
Dim strReplace As String
Dim regEx As Variant
Dim strtxt As String
Set regEx = CreateObject("vbscript.regexp")
strtxt = "String1.String2.String3.String4.String5.String6.String7.String77"
strPattern = "(String.)" ' (String\d+) for replacing e.g. 'String77' etc.
strReplace = ""
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If regEx.Test(strtxt) Then
Debug.Print regEx.Replace(strtxt, strReplace)
Else
MsgBox ("Not matched")
End If
End Sub
regexr
One way:
Function RemoveTokens(target As String, ParamArray tokens() As Variant) As String
Dim i As Long
For i = 0 To UBound(tokens)
target = Replace$(target, tokens(i), "")
Next
RemoveTokens = target
End Function
?RemoveTokens("AA BB CC DD EE", "BB")
AA CC DD EE
?RemoveTokens("AA BB CC DD EE", "BB", "EE", "AA")
CC DD
Related
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
I am trying to get all values in columns D and E which include only these with brackets - like ;;;;VariableG5>
but without these with text NEW_LINE.I found only how to extract the text between the brackets, but I want to extract it with the brackets.This is what I found:
Public Sub My_Split()
Dim z As Variant
z = Split(Replace(Join(Filter(Split(Replace(Replace(Selection.Value, "<" , ">")
Selection.Offset(0, 1).Resize(, UBound(z) + 1) = z
End Sub
Sub simpleRegex()
Dim strPattern As String: strPattern = " <([a-z] | [A-Z] | [0-9] | \. | - | _)+>"
Dim Match As Object
Dim matches As Object
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
Dim strInput As String
Dim Myrange As Range
Set Myrange = ActiveSheet.Range("D8:D10")
For Each cell In Myrange
If strPattern <> "" Then
strInput = cell.Value
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If regex.Test(strInput) Then
Set matches = regex.Execute(strInput)
For Each Match In matches
MsgBox (Match.Value) 'A workaround I found to see if my pattern
'worked but I need to print Match.value
'in a column so this wont do
Next
Else
MsgBox ("Not matched")
End If
End If
Next
End Sub
File sample.txt:
something
------
--------
------
xyz
12 34 56
78 90 10
11 12 1ds3
14 15 16 17
abc
something
------
--------
------
xyz
14 34 566
785 490 10
113 142 1ds3
143 155 616 17
abc
Now I want to write a VBScript to read sample.txt and copy only those data that fall between xyz and abc.
I tried the following:
Sub test1()
Dim fso As FileSystemObject
Dim strMerge As String
Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile("filepath", ForReading, False)
Do While txtStream.AtEndOfStream <> True
If InStr(txtStream.ReadLine, "xyz") <> 0 Then
strMerge = strMerge & txtStream.ReadLine
Do While Not InStr(txtStream.ReadLine, "abc") <> 0
strMerge = strMerge + txtStream.ReadLine
Loop
Else
strMerge = strMerge & txtStream.ReadLine
End If
Next i
Loop
MsgBox (strMerge)
txtStream.Close
End Sub
Solution using RegEx
Sub test1()
Dim fso As FileSystemObject
Dim strMerge As String
Dim txtStream As Variant
Dim textLine As String
Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile("C:\Users\pankaj.jaju\Desktop\test.txt", ForReading, False)
txt = txtStream.ReadAll
Dim objRegEx, oRegResults
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.IgnoreCase = True
.MultiLine = True
.Global = True
.Pattern = "xyz\s*([\S\s]*?)\s*?\S*?abc"
End With
Set oRegResults = objRegEx.Execute(txt)
For Each txtMatch In oRegResults
MsgBox txtMatch.Submatches(0)
Next
txtStream.Close
End Sub
Assuming you don't want to read XYZ nor ABC here you go.
Sub test1()
Dim ReadEn As Boolean
Dim fso As FileSystemObject
Dim strMerge As String
Dim tStr As String
Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile("c:\projects\sample.txt", ForReading, False)
ReadEn = False
Do While txtStream.AtEndOfStream <> True
tStr = txtStream.ReadLine
If InStr(tStr, "abc") > 0 Then ReadEn = False
' do not read "xyz"
If ReadEn Then
strMerge = strMerge & tStr & Chr(13)
End If
If InStr(tStr, "xyz") > 0 Then ReadEn = True
Loop
MsgBox (strMerge)
txtStream.Close
End Sub
I switch on ReadEn to enable reading the file to tStr I don't ReadLine because I may past the EOF while still in the loop.
Not sure if you wanted to read blanks as well, but they will be read and output. If you want to output xyz and abc sawp the location of their if-statements.
there was:
a next i not "in scope"
Readline() handling skipped every two lines of txt file
try this
Option Explicit
Sub test1()
Dim fso As FileSystemObject
Dim strMerge As String
Dim txtStream As Variant
Dim textLine As String
Set fso = New FileSystemObject
Set txtStream = fso.OpenTextFile("filepath", ForReading, False)
Do While txtStream.AtEndOfStream <> True
textLine = txtStream.ReadLine
If InStr(textLine, "xyz") <> 0 Then
textLine = txtStream.ReadLine
Do While Not InStr(textLine, "abc") <> 0
strMerge = strMerge & textLine
textLine = txtStream.ReadLine
Loop
End If
Loop
MsgBox strMerge
txtStream.Close
End Sub
of course you have to change "filepath" to a string contianing the actual full path of the desired txt file
Just use some disposable objects and well placed splits.
Sub test1()
Dim ecA, ec(): ReDim ec(0)
ecA = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\testenv\test.txt", 1).ReadAll, "xyz")
For I = 1 To UBound(ecA): ec(UBound(ec)) = Split(ecA(I), "abc")(0): ReDim Preserve ec(UBound(ec) + 1): Next
ReDim Preserve ec(UBound(ec) - 1)
End Sub
With the followoing code I can fetch the price table from this webpage http://www.idealo.de/preisvergleich/OffersOfProduct/143513.html
But from another page here this table is not being fetched...though these two pages are identical. I can't figure out where am lacking.
Any help on this is deeply appreciable.
Sub TableExample()
Dim IE As Object
Dim doc As Object
Dim strURL As String
strURL = "http://www.idealo.de/preisvergleich/OffersOfProduct/143513.html"
Set IE = CreateObject("InternetExplorer.Application")
With IE
.navigate strURL
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Set doc = IE.document
GetAllTables doc
.Quit
End With
End Sub
Sub GetAllTables(doc As Object)
Dim ws As Worksheet
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim i As Long
Set ws = Sheets("Sheet1")
For Each tbl In doc.getElementsByTagName("TABLE")
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
If tabno = 5 Then
For Each rw In tbl.Rows
colno = 5
For Each cl In rw.Cells
If colno = 5 And nextrow > 5 Then
Set classColl = doc.getElementsByClassName("shop")
Set imgTgt = classColl(nextrow - 6).getElementsByTagName("img")
rng.Value = imgTgt(0).getAttribute("alt")
Else
rng.Value = cl.innerText
End If
Set rng = rng.Offset(, 1)
i = i + 1
colno = colno + 1
Next cl
nextrow = nextrow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next rw
End If
Next tbl
End Sub
The table numbers change between the two urls. Table 5 is the table you're interested in for the first url, but Table 6 is the one of interest in the 2nd url. However both tables of interest have the same id ("offers-list"), so instead of looking for the fifth table, adjust your code to look for the Table with the ID "offers-list"
change
If tabno = 5 Then
to
If InStr(1, tbl.outerhtml, "Produktbezeichnung des Shops", vbTextCompare) > 0 Then
This will get you close. There are other changes on the second web page that your current code isn't quite handling - but like I said this will get you close.
I have changed the If tabno = 5 Then with
For Each tbl In doc.getElementsByTagName("table")
' tabno = tabno + 1
If tbl.className = "orangebox_rowborder" Then
Thanks #Ron for guiding me for this...thanks a ton Dude
The following works for each URL so is more robust and is a lot faster than the method you are currently using as it does away with the IE browser nvaigation.
For a lengthy code explanation please see here.
Option Explicit
'Tools > References > HTML Object Library
Public Sub GetTable()
Const URL = "https://www.idealo.de/preisvergleich/OffersOfProduct/1866742_-335-billingham.html" '<==Change this
Dim sResponse As String, listItems As Object, html As HTMLDocument, headers()
headers = Array("product_id", "product_name", "product_price", "product_category", "currency", "spr", "shop_name", "delivery_time", "shop_rating", "position", "free_return", "approved_shipping")
Application.ScreenUpdating = False
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
Set html = New HTMLDocument
With html
.body.innerHTML = sResponse
Set listItems = .getElementsByClassName("productOffers-listItemOfferPrice")
End With
Dim currentItem As Long
With ActiveSheet
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For currentItem = 0 To listItems.Length - 1
Dim tempString As String, columnValues() As String
tempString = TidyString(GetTransactionInfo(listItems(currentItem).outerHTML), "&#\d+;")
columnValues = GetColumnValues(tempString, headers)
.Cells(currentItem + 2, 1).Resize(1, UBound(columnValues) + 1) = columnValues
Next currentItem
End With
Application.ScreenUpdating = True
End Sub
Public Function GetTransactionInfo(ByVal inputString) As String
'Split to get just the transaction items i.e. Headers and associated values
GetTransactionInfo = Split(Split(inputString, """transaction"",")(1), "}")(0)
End Function
Public Function TidyString(ByVal inputString As String, ByVal matchPattern As String) As String
'Extract transaction info
'Use regex to find these unwanted strings and replace pattern e.g. &#\d+;
'Example inputString
Dim regex As Object, tempString As String
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = matchPattern
End With
If regex.test(inputString) Then
TidyString = regex.Replace(inputString, vbNullString)
Else
TidyString = inputString
End If
End Function
Public Function GetColumnValues(ByVal inputString As String, ByVal headers As Variant) As Variant
' Example input string "product_id": "143513","product_name": "Canon 500D Nahlinse 72mm","product_price": "128.0","product_category": "26570","currency": "EUR","spr": "cfd","shop_name": "computeruniverse.net","delivery_time": "long","shop_rating": "100","position": "1","free_return": "14","approved_shipping": "false"
' Extract just the inner string value of each header e.g. 143513
Dim arr() As String, currentItem As Long, tempString As String
tempString = inputString
For currentItem = LBound(headers) To UBound(headers)
tempString = TidyString(tempString, Chr$(34) & headers(currentItem) & Chr$(34) & ":")
Next currentItem
arr = Split(Replace$(tempString, Chr$(34), vbNullString), ",")
GetColumnValues = arr
End Function
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