I'm trying to create a function that would allow me to pass in a variable that gets added to an object. I want to be able to move a row of values up to the next line in a Form. I want to add a variable so that I don't have to keep repeating the same code for every single row.
Function UpArrow(x As Variant, y As Variant)
Dim TextContent As String
cboOperation +x+ .Value = TextContent
cboOperation +x+ .Value = cboOperation +y+ .Value
cboOperation +y+ .Value = TextContent
I think you are looking for the Controls collection.
Function UpArrow(x As Variant, y As Variant)
Dim TextContent As String
TextContent = Controls("cboOperation" & x).value
Controls("cboOperation" & x).value = Controls("cboOperation" & y).value
Controls("cboOperation" & y).value = TextContent
End Function
Related
I have this code in VBA and I want to extract '15' of obj-amount div class. Any suggestion?
<div class="obj-amount">15<span class="unit">$</span></div>
Set divtags = oHtml.getElementsByClassName("obj-amount")(0).getElementsByTagName("obj-amount")
i = 0
For Each oElement In divtags
Sheets("Data").Range("A" & i + 1) = divtags(i).innerText
i = i + 1
Next oElement
Returning a collection and looping:
You don't want to chain together ByClassName and ByTagName. Your selector inside is for classname alone and is sufficient to return a collection of elements with that classname.
You don't want to index at that level either, if after all elements with this class name for a loop. You want to For Each over the collection. Then in the loop you want to work with the loop variable, oElement; that'll mean you can start i=1 and reduce the amount of code and calls for addition in the loop.
This will of course return the $ which resides in the child span tag.
Ways to avoid/remove the $ (or child span content):
The simplest way to remove this, if unwanted, is to use Replace$ on the .innerText during the loop.
If that text is not constant then you can do a replacement of oElement.children(0).innerText with vbNullString on the .innerText, or of oElement.getElementsByTagName("span")(0).innertext. The latter I think might have been what you were after doing (but it needed to be in the loop.).
You could also have done oElement.FirstChild.NodeValue without a replacement.
N.B.
Which methods are available to you will depend on how you declared divtags and oElement.
Long text version:
Set divtags = ohtml.getElementsByClassName("obj-amount") '<== collection matched by classname
i = 1
For Each oElement In divtags '<== loop each item in collection
Worksheets("Data").Range("A" & i) = oElement.innerText
'Worksheets("Data").Range("A" & i) = oElement.FirstChild.NodeValue
'Worksheets("Data").Range("A" & i) = Replace$(oElement.innerText,"$", vbNullString) '<==replacement if wanted
'Worksheets("Data").Range("A" & i) = Replace$(oElement.innerText,oElement.children(0).innerText, vbNullString) '<==replacement if wanted and first child text not constant
'Worksheets("Data").Range("A" & i) = Replace$(oElement.innerText,oElement.getElementsByTagName("span")(0).innertext, vbNullString) '<==replacement if wanted and child span text not constant
i = i + 1
Next oElement
Using With statement and Worksheet variable for legibility:
I would probably put the worksheet into a variable and ensure I am working with Worksheets collection. I would also use With statement to hold reference to oElement inside the loop, so as to use dot accessor, . , for legibility:
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Data")
Set divtags = ohtml.getElementsByClassName("obj-amount")
i = 1
For Each oElement In divtags
With oElement
ws.Range("A" & i) = .FirstChild.NodeValue
ws.Range("A" & i) = Replace$(.innerText, "$", vbNullString) 'next two lines are alternativeS based on need
ws.Range("A" & i) = Replace$(.innerText, .Children(0).innerText, vbNullString)
ws.Range("A" & i) = Replace$(.innerText, .getElementsByTagName("span")(0).innerText, vbNullString)
End With
i = i + 1
Next oElement
I have a problem extracting words in MS Excel. I have multiple sentences in HTML format in a row and want to extract all of the words that are delimited by <b>....</b>
Example:
<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>
I want to extract the words: "buat", "1", "2", "cendol"
Can you help me to solve my problem? Any code in Excel/VBA is appreciated.
This can be done with the worksheet function FILTERXML if you have Excel 2013+
First you need to change your string into a "well-formed" XML by enclosing it in an external tag, and closing off the unmatched <br> tag:
"<t>" & $A$1 & "</br></t>"
Then it's merely a matter of using an Xpath that will return all of the wanted tags:
FILTERXML("<t>" & $A$1 & "</br></t>","//b")
Wrapping that in an INDEX function allows you to extract the substrings one at a time:
Full Formula entered in A3 and filled down
=IFERROR(INDEX(FILTERXML("<t>" & $A$1 & "</br></t>","//b"),ROWS($1:1)),"")
There's a very easy way to do this by using an HTMLDocument object:
In your VB Editor, go to Tools>References and select the Microsoft HTML Object Library.
Then you can use the following code:
Sub extract()
Dim doc As New HTMLDocument 'Declare and create an object of type HTMLDocument
Dim item As HTMLObjectElement 'Declare an object of type HTMLObjectElement. We will use this to loop through a collection of HTML elements
doc.body.innerHTML = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> " 'Assign your HTML code as a string in doc body
For Each item In doc.getElementsByTagName("b") 'Loop through all the <b></b> elements in doc
Debug.Print item.innerText 'print the text contained in <b></b> element. This will show up in your immediate window
Next item
End Sub
Try this
Sub Test()
Dim objReg As Object
Dim objMatches As Object
Dim match As Object
Dim s As String
Dim i As Integer
s = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
Set objReg = CreateObject("VBScript.RegExp")
With objReg
.IgnoreCase = False
.Global = True
.Pattern = "<b>(.*?)<\/b>"
Set objMatches = .Execute(s)
End With
For Each match In objMatches
For i = 0 To match.Submatches.Count - 1
Debug.Print Trim(match.Submatches.item(i))
Next i
Next match
Set objReg = Nothing
End Sub
Alternative using XML DomDocument
Analyzing a HTML string it seems evident to use document object structures as in a HTMLDocument or in ►XML. That's why I demonstrate a further approach for the sake of completeness and in addition to #StavrosJon 's valid solution (which uses the more lenient HTMLDocument not needing to be well formed as XML is):
Example call
Sub ExtractViaXML()
Dim html$, myArray()
html = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> "
myArray = getTokens(html, "b") ' assign findings to array via function getTokens()
Debug.Print UBound(myArray) + 1 & " token(s) found: " & Join(myArray, ", ") ' display results
End Sub
Main function getTokens()
Function getTokens(ByVal html$, Optional myTag$ = "b") As Variant()
' Purpose: isolate "<b>"-Tags (default value) out of html string and return found tokens as variant array
' Note: creates temporary XML DOMDocument (late bound MSXML2 reference)
Dim XmlString$
XmlString = wellformed("<?xml version=""1.0"" encoding=""utf-8""?><tokens>" & html & "</tokens>")
With CreateObject("MSXML2.DOMDocument.6.0")
.ValidateOnParse = True: .Async = False
If .LoadXML(XmlString) Then ' load xml string
Dim myNodeList As Object
Set myNodeList = .DocumentElement.SelectNodes(myTag) ' set node list to memory
Dim i&, ii&, arr()
ii = myNodeList.Length - 1 ' calculate upper boundary of zero-based array
If ii > -1 Then ReDim arr(ii) ' (re)dimension variant array arr()
For i = 0 To ii ' loop through node list
arr(i) = myNodeList.item(i).Text ' assign each found text content to array
Next i
If ii = -1 Then arr = Array("**Nothing found**") ' provide for zero findings
getTokens = arr ' return 0-based 1-dim array with found tokens
Else: ShowParseError (.ParseError) ' optional: display possible error message
End If
End With
End Function
Helper functions
XML requires a well formed node structure with opening and closing tags or, whereas HTML is more lenient towards e.g. single line breaks(<br>). Therefore I added a simple function wellformed() to cure such an issue preventing successful loading. Furthermore I demonstrate using an optional procedure ShowParseError to localize (other) possible loading Errors which you can use as supplement to any .load or .loadXML function.
Function wellformed$(ByVal s$)
' Purpose: force a wellformed version of line breaks in html/xml string ("<br/>")
' Note: unclosed tags like <br> only would prevent a successful load of the xml document
wellformed = Replace(Replace(s, "</br>", "<br>"), "<br>", "<br/>")
End Function
Sub ShowParseError(pe As Object)
' Purpose: display possible parse error
' Note: localizes error occurrence also by indicating position
Dim ErrText$
With pe
ErrText = "Load error " & .ErrorCode & " xml file " & vbCrLf & _
Replace(.URL, "file:///", "") & vbCrLf & vbCrLf & _
.reason & _
"Source Text: " & .srcText & vbCrLf & vbCrLf & _
"Line No.: " & .Line & vbCrLf & _
"Line Pos.: " & .linepos & vbCrLf & _
"File Pos.: " & .filepos & vbCrLf & vbCrLf
End With
MsgBox ErrText, vbExclamation
End Sub
I tried something different, with splitting and joining and splitting again and looping trough array. I typed the text <b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b> in cell A1:
Sub Macro1()
Dim MyWords As Variant
Dim i As Long
Dim MyDelimiter As String
Dim MyLen As Byte
MyDelimiter = "||" 'Choose 1 not common delimiter
MyLen = Len(MyDelimiter)
MyWords = Split(Join(Split(Range("A1").Value, "<b>"), MyDelimiter), "</b>")
For i = 0 To UBound(MyWords) Step 1
Debug.Print Mid(MyWords(i), InStr(1, MyWords(i), MyDelimiter) + MyLen, 99) 'Increase 99 if you are sure there will be longer texts between tags <b>..</b>
Next i
Erase MyWords
End Sub
I get this:
i have tried to simulate this on excel. please check my sample solution below.
Sub test()
Dim testString As String
Dim startPos As Integer
Dim endPos As Integer
Dim resultString As String
Dim str As String
testString = "<b>buat</b> <i>v</i> <b>1</b> kerjakan; lakukan; <b>2</b> bikin;<br>--<b> cendol</b>"
'get the position of start tag
startPos = InStr(1, testString, "<b>") + 3
'get the position of end tag
endPos = InStr(startPos, testString, "</b>")
Do While Len(testString) > 1
'check if the start pos and end pos is correct
If startPos > 0 And endPos > startPos Then
'get the value in between the start tag and end tag
str = Mid(testString, startPos, endPos - startPos)
resultString = resultString + str + ","
'remove the value retrieved from the original string
testString = Mid(testString, endPos + 4)
startPos = InStr(1, testString, "<b>") + 3
endPos = InStr(startPos, testString, "</b>")
End If
Loop
End Sub
I need to find the string in the attached picture using a vba in excel. I have the code below, but it is not finding the date that I am looking for.
The for loop to find is at the last "For Each Element In Elements2"
Dim Doc As HTMLDocument
Dim Elements As IHTMLElementCollection
Dim elements1 As IHTMLElementCollection
Dim Elements2 As IHTMLElementCollection
Dim iCnt As Integer
Dim Element As IHTMLElement
Dim appIE As InternetExplorerMedium
Sheets(1).Cells(1, 1).Value = ""
complete = 0
Set appIE = New InternetExplorerMedium
sURL = "https://example.com"
With appIE
.Navigate sURL
.Visible = True
Do While appIE.Busy Or appIE.ReadyState <> 4
DoEvents
Loop
Do While complete <> 1
Set Doc = appIE.Document
Set Elements = Doc.GetElementsByTagName("input")
Set elements1 = Doc.GetElementsByTagName("strong")
Set Elements2 = Doc.GetElementsByTagName("td")
For Each Element In Elements
If Element.ID = "form-id" Then
requestnumber = Element.GetAttribute("Value")
End If
If Element.ID = "remedy-case-info" Then
CaseInfo = Element.GetAttribute("Value")
End If
Next Element
For Each Element In elements1
If InStr(1, Element.InnerHtml, "EM") Then
For iCnt = 1 To Len(Element.InnerText)
If IsNumeric(Left(Element.InnerText, 2)) Then
NumericOnly (Element.InnerText)
End If
Next iCnt
End If
Next Element
AClientCount = tempcount
For Each Element In Elements2
' If InStr(1, Element.InnerHtml, "td") Then
If InStr(1, Element.InnerHtml, "value-field align-top") Then
Requestdate = Element.GetAttribute("Value")
End If
' End If
Next Element
Set Elements = Nothing
If requestnumber <> "" Then
Sheets(1).Cells(1, 1).Value = requestnumber & " - " & CaseInfo & " - " & tempcount & " - " & Requestdate
complete = 1
End If
Loop
.Quit
End With
The innerHtml property picks up the content within a tag but does not pick up the tag itself. The outerHTML property includes the tag itself as well as the tag's content.
Example:
HTML <p class="fee fie foe fum">bar <b>bat</b> <i>cat</i> car</p>
innerHTML bar <B>bat</B> <I>cat</I> car
outerHTML <P class="fee fie foe fum">bar <B>bat</B> <I>cat</I> car</P>
To perform a text match on an attribute value of an element, you would need to look at the outerHTML property of the element and not the innerHTML property.
However, the class attribute of an element can be accessed via the className property so you could replace the InStr on innerHTML with this:
If InStr(1, Element.className, "value-field align-top") Then
This is not ideal because it would be perfectly valid to write the class names in a different order - e.g. class="align-top value-field" - and this would not be picked up by the InStr function.
It would be better to start with getElementsByClassName (which doesn't care about which order the class names are in) and then use the tagName property to check we have the correct tag, like this:
Set Elements2 = Doc.getElementsByClassName("value-field align-top")
' code for the loops on Elements and Elements1 goes here
For Each Element In Elements2
If Element.tagName = "td" Then
Finally, Element.getAttribute("value") will return Null unless the element has a named attribute called "value". To get the text value of the element, use this instead:
Requestdate = Element.innerText
I am seeing a strange situation when a function takes a column of field values from an Access table and put those in a VBA collection and returns the collection. The function takes a table name and field name as arguments and returns a collection with all (or unique) values in the column of fields. When a sub runs this function, the sub can read out a count of elements in the resulting collection. However, when the sub tries to access the elements errors results.
I say “errors” because I get a different error when I try to access elements in different ways. For example if I try to access a collection element via the key:
For i=0 to col.count
Debug.Print col(Cstr(i)) ' results in error: "Automation error"
i=i+1
Next
I get an “Automation Error.” But when I try to access collection elements via For Each
For Each var in col
Debug.Print var ' results in error: "Object invalid or no longer set."
Next
What is also strange is that the elements of the collection can be accessed within the function that will be returning it, but not once the collection is returned to the calling sub. But the calling sub can access the collection count.
The same approach with Access tables works fine to put a column of field values into an array. After the function returns an array of a column of field values, the array can be converted to a collection. The resulting collection can be passed to and used in another sub. But the method does not work to have a function get info from Access, pack it into a collection and return the collection with info from Access to the calling sub.
My code is below. I've tried but could not find any even remotely related questions.
Option Compare Database
Option Explicit
Sub colUniqueTableValues_tester()
Dim col As New Collection
Dim var As Variant
Dim i As Integer
Dim strTable As String: strTable = "tbl_Projects"
Dim strField As String: strField = "Project_Code"
Set col = colUniqueTableValues(strTable, strField)
Debug.Print "colListOfUniqueValues_tester: col.count = " + CStr(col.Count)
' Set col = colAnyLengthAndStep(4, 1) ' sub will complete if the collection from Access is overwritten
i = 0
For Each var In col
i = i + 1
Debug.Print CStr(i) + ": " + col(CStr(i)) ' results in error: "Automation error"
Debug.Print var ' returns error: "Object invalid or no longer set."
Next
Set col = Nothing
End Sub
Function colUniqueTableValues(ByVal strTable As String, ByVal strField As String) As Collection
Dim strSQL As String
Dim rs As Recordset
Dim dbs As Database
Dim i As Integer
Dim col As New Collection
strSQL = "Select distinct " + strField + " from " + strTable
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset(strSQL)
i = 0
rs.MoveFirst
Do While Not rs.EOF
col.Add rs.Fields(strField), CStr(i)
Debug.Print "Function: " + col(CStr(i)) 'check value
rs.MoveNext
i = i + 1
Loop
Set colUniqueTableValues = col
Debug.Print "colUniqueTableValues: colUniqueTableValues.count = " + CStr(colUniqueTableValues.Count)
Set dbs = Nothing
Set rs = Nothing
Set col = Nothing
End Function
Function colAnyLengthAndStep(ByVal intLength As Integer, ByVal intStep As Integer) As Collection
Dim col As New Collection
Dim i As Integer
Dim var As Variant
For i = 1 To intLength * intStep Step intStep
col.Add "Value" + CStr(i), CStr(i)
Next
Set colAnyLengthAndStep = col
Set col = Nothing
End Function
The first issue is due to the fact that rs.Fields(strField) is a field object. In many situations, when you do something with a field, you're implicitly referencing its default property, which is .Value. For example, these two are essentially the same:
Debug.Print rs.Fields(strField)
Debug.Print rs.Fields(strField).Value
However, the collection's .Add method is different in that it will accept the actual object itself instead of the object's .Value. To see what's actually happening, make this change in colUniqueTableValues():
col.Add rs.Fields(strField), CStr(i)
Debug.Print TypeName(col(CStr(i))) ' <- this says Field2 on my system
You must explicitly reference the field's .Value property to add it to the collection properly:
col.Add rs.Fields(strField).Value, CStr(i)
After that change, you will expose an error in colUniqueTableValues_tester. When you added items to the collection, you gave them keys using CStr(i) starting with i = 0. However, in the For Each loop in colUniqueTableValues_tester, i starts at 1. Change the loop to this:
For Each var In col
'i = i + 1
Debug.Print CStr(i) & ": " & col(CStr(i))
Debug.Print var
i = i + 1
Next
I have a variable strFunction, then I have another string strName = "strFunction" , what I want to know is how can I get the value of strFunction by using strName.
For example, something like getValue(strName) gives me the value of strFunction. Is it possible in Access VBA?
Thanks!
EDIT:
I have a strFunction string, it's a const string.
In my code I want to use Len("strFunction") to test the length of it, but what i got is the length "strFunction". So I need a get-value-out-of-variable-name function. I have tried Eval(), but it cannot do this, even I write a get_strFunction(), eval("get_strFunction()") gives me error, telling me it cannot find it.
Private Const strFunction as String = "FilterByType_1"
Private Function get_strFunction()
get_strFunction = strFunction
End Function
"I have a variable strFunction, then I have another string strName = "strFunction" , what I want to know is how can I get the value of strFunction by using strName."
Instead of a variable, strFunction could be the key for an item in a VBA collection.
Public Sub darkjh()
Dim strName As String
Dim col As Collection
Set col = New Collection
col.Add "FilterByType_1", "strFunction"
strName = "strFunction"
Debug.Print col(strName)
Set col = Nothing
End Sub
Edit: Instead of a VBA collection, you could use a Scripting.Dictionary.
Dim strName As String
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Add "strFunction", "FilterByType_1"
strName = "strFunction"
Debug.Print dict(strName)
Set dict = Nothing
Option Compare Database
Dim a As String
Dim b As String
Public Sub test()
a = "b"
b = "test-string"
Debug.Print Eval("get" & a & "()")
End Sub
Public Function getB() As String
getB = b
End Function
Output
>>test
test-string
eval(a) did not work, so I had to write a "getter" for the variable and eval that function: eval("get" & a & "()").