Related
Hope somebody might able to help me.
I am a real rookie in this field, had a friend of mine write up the following code some time ago.
I have VB in Excel that gets data from a yahoo API, URL: "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
The data gets inserted in excel and is auto-refreshed every minute.
Everything works smoothly with no issues.
Now to the challange, since the data gets auto purged after a day in the excel, I would need to extend the amount of data (rows) from the current 1 day to 7 days.
So I tried simply to change the URL from the above mentioned to the following:
"https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=7d"
However the parsing in the code gives me errors which I am to bad at solving..
First warning comes in the code:
"Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)"
And the whole code is as below (feel free to try it in excel if you would like), thanks in advance.
Option Explicit
Private p&, token, dic
Function ParseJSON(json$, Optional key$ = "obj") As Object
p = 1
token = Tokenize(json)
Set dic = CreateObject("Scripting.Dictionary")
If token(p) = "{" Then ParseObj key Else ParseArr key
Set ParseJSON = dic
End Function
Function ParseObj(key$)
Do: p = p + 1
Select Case token(p)
Case "]"
Case "[": ParseArr key
Case "{": ParseObj key
Case "{"
If token(p + 1) = "}" Then
p = p + 1
dic.Add key, "null"
Else
ParseObj key
End If
Case "}": key = ReducePath(key): Exit Do
Case ":": key = key & "." & token(p - 1)
Case ",": key = ReducePath(key)
Case Else: If token(p + 1) <> ":" Then dic.Add key, token(p)
End Select
Loop
End Function
Function ParseArr(key$)
Dim e&
Do: p = p + 1
Select Case token(p)
Case "}"
Case "{": ParseObj key & ArrayID(e)
Case "[": ParseArr key
Case "]": Exit Do
Case ":": key = key & ArrayID(e)
Case ",": e = e + 1
Case Else: dic.Add key & ArrayID(e), token(p)
End Select
Loop
End Function
Function Tokenize(s$)
Const Pattern = """(([^""\\]|\\.)*)""|[+\-]?(?:0|[1-9]\d*)(?:\.\d*)?(?:[eE][+\-]?\d+)?|\w+|
[^\s""']+?"
Tokenize = RExtract(s, Pattern, True)
End Function
Function RExtract(s$, Pattern, Optional bGroup1Bias As Boolean, Optional bGlobal As Boolean = True)
Dim c&, m, n, v
With CreateObject("vbscript.regexp")
.Global = bGlobal
.MultiLine = False
.IgnoreCase = True
.Pattern = Pattern
If .TEST(s) Then
Set m = .Execute(s)
ReDim v(1 To m.Count)
For Each n In m
c = c + 1
v(c) = n.Value
If bGroup1Bias Then If Len(n.submatches(0)) Or n.Value = """""" Then v(c) = n.submatches(0)
Next
End If
End With
RExtract = v
End Function
Function ArrayID$(e)
ArrayID = "(" & e & ")"
End Function
Function ReducePath$(key$)
If InStr(key, ".") Then ReducePath = Left(key, InStrRev(key, ".") - 1) Else ReducePath = key
End Function
Function ListPaths(dic)
Dim s$, v
For Each v In dic
s = s & v & " --> " & dic(v) & vbLf
Next
Debug.Print s
End Function
Function GetFilteredValues(dic, match)
Dim c&, i&, v, w
v = dic.keys
ReDim w(1 To dic.Count)
For i = 0 To UBound(v)
If v(i) Like match Then
c = c + 1
w(c) = dic(v(i))
End If
Next
ReDim Preserve w(1 To c)
GetFilteredValues = w
End Function
Function GetFilteredTable(dic, cols)
Dim c&, i&, j&, v, w, z
v = dic.keys
z = GetFilteredValues(dic, cols(0))
ReDim w(1 To UBound(z), 1 To UBound(cols) + 1)
For j = 1 To UBound(cols) + 1
z = GetFilteredValues(dic, cols(j - 1))
For i = 1 To UBound(z)
w(i, j) = z(i)
Next
Next
GetFilteredTable = w
End Function
Function OpenTextFile$(f)
With CreateObject("ADODB.Stream")
.Charset = "utf-8"
.Open
.LoadFromFile f
OpenTextFile = .ReadText
End With
End Function
Function toUnix(dt) As Long
toUnix = DateDiff("s", "1/1/1970 00:00:00", dt)
End Function
Function fromUnix(ts) As Date
fromUnix = DateAdd("s", ts, "1/1/1970 00:00:00")
End Function
Private Sub GetData()
' Queue next invocation
Application.OnTime Now + TimeValue("00:01:00"), "GetData"
Dim DataSheet As Worksheet
Set DataSheet = Sheets("Data")
Dim ParameterSheet As Worksheet
Set ParameterSheet = Sheets("Parameters")
Dim scrape As String
scrape = ParameterSheet.Range("B2").Value
If scrape <> "TRUE" Then
Exit Sub
End If
Dim ticker As String
ticker = ParameterSheet.Range("A2").Value
Dim url As String
url = "https://query2.finance.yahoo.com/v8/finance/chart/" & ticker & "?interval=1m&range=1d"
Dim hReq As Object
Set hReq = CreateObject("MSXML2.XMLHTTP")
With hReq
.Open "GET", url, False
.Send
End With
Dim json As Object
Set json = ParseJSON(hReq.ResponseText)
Dim closes As Variant
closes = GetFilteredValues(json, "*.close*")
Dim opens As Variant
opens = GetFilteredValues(json, "*.open*")
Dim volumes As Variant
volumes = GetFilteredValues(json, "*.volume*")
Dim highs As Variant
highs = GetFilteredValues(json, "*.high*")
Dim lows As Variant
lows = GetFilteredValues(json, "*.low*")
Dim timestamps As Variant
timestamps = GetFilteredValues(json, "*.timestamp*")
Dim i As Integer
i = UBound(timestamps) + 1
Dim row As Integer
row = 2
' Load new data in
Dim timestamp As Variant
For Each timestamp In timestamps
i = i - 1
timestamp = Int(timestamps(i) / 60) * 60
If "null" = closes(i) Then
GoTo Continue
End If
If DataSheet.Range("H" & row).Value = "" Then
' Empty dataset
ElseIf toUnix(DataSheet.Range("H" & row).Value) < timestamp Then
' There is new data, prepend
DataSheet.Rows(row).Insert
ElseIf toUnix(DataSheet.Range("H" & row).Value) = timestamp Then
' Replace old data,
Else: GoTo Continue
End If
DataSheet.Range("B" & row).Value = ticker
DataSheet.Range("C" & row).Value = opens(i)
DataSheet.Range("D" & row).Value = highs(i)
DataSheet.Range("E" & row).Value = lows(i)
DataSheet.Range("F" & row).Value = closes(i)
DataSheet.Range("G" & row).Value = volumes(i)
DataSheet.Range("H" & row).Value = fromUnix(timestamp)
row = row + 1
Continue:
Next timestamp
' Remove data that is more then 10 days old
row = 1
Do While True
row = row + 1
Dim datee As Variant
datee = DataSheet.Range("H" & row).Value
If datee = "" Then
Exit Do
End If
If toUnix(datee) + 864000 < toUnix(Now()) Then
DataSheet.Rows(row).EntireRow.Delete
row = row - 1 ' This prevents skipping the next line
End If
Loop
End Sub
Private Sub Auto_Open()
GetData
End Sub
Problem is the parsing code cannot deal with the multiple trading periods which in the JSON are arrays within arrays [[{}],[{}],[{}]] when the range is greater than 1 day. The array index counter e is reset at each opening bracket so you get identical keys for each trading period. Dictionary keys must be unique hence the error. The best solution would be to rewrite using a modern parser but as a quick-fix hack the ParseArr function as follows ;
Function ParseArr(key$)
'Dim e& move to top of script
' add this line
If InStr(1, key, "tradingPeriods") = 0 Then e = 0
Do: p = p + 1
' no change to this code
Loop
End Function
Newbie here. I have an HTML source code and would like to look for string in between header tags <h1></h1>, <h2></h2>till <h5></h5> and then convert the text to lower case except acronyms or abbreviations (these are all capitals in 2 or more characters). And make sure that all country names in between use proper case.
As an example: It will find <h1>HR Policies and Procedures for Hiring - argentina LTD</h1>
It will convert it to:<H1>HR policies and procedures for hiring - Argentina LTD</H1>
I've tried a user defined function for Excel VBA found online: CapIt(A2). It uses Search, Split and Join. I'm not able to put them together to come up with the result. Would appreciate very much your help. Thank you.
Code I saw online as initial reference:
Function Capit(s As String)
Dim v As Variant, j As Long
v = Split(s, " ") ' separates the words
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capit = Join(v, " ") ' joins the words
End Function
'Added this code below, can we use the results to lowercase the string and exclude the output in this function
Function FindAcronyms(yourWord As String)
Dim I As Integer
Dim ctr As Integer
FindAcronyms = Null
For I = 1 To Len(yourWord)
If Asc(Mid(yourWord, I, 1)) <= 90 And _
Asc(Mid(yourWord, I, 1)) >= 65 Then
If ctr > 0 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
ctr = ctr + 1
Else
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1) & ", "
End If
ctr = 0
End If
Next
If ctr > 1 Then
FindAcronyms = FindAcronyms & Mid(yourWord, I - 1, 1)
End If
If Right(FindAcronyms, 2) = ", " Then
FindAcronyms = Left(FindAcronyms, Len(FindAcronyms) - 2)
End If
End Function
'the final look would be something like this
Sub TitleChange()
'define array
myarray = Range("A1:A100")
' Define the pattern
Dim pattern As String: pattern = "<h*>*</h*>" 'looks for the header tags
Dim f As Variant
For Each f In myarray
If f Like pattern = True Then Capital (f) 'changes all string to lower case except countries (to retain proper case) and acronyms (to retain uppercase)
Next f
End Sub
You can include the countries in an array
Sub Test()
Debug.Print Capital("HR Policies and Procedures for Hiring - argentina LTD")
End Sub
Function Capital(ByVal s As String)
Dim a, v As Variant, j As Long
a = Array("Argentina", "Egypt", "Enland")
v = Split(s, " ")
For j = LBound(v) To UBound(v)
If StrComp(v(j), UCase(v(j)), vbBinaryCompare) <> 0 Then v(j) = StrConv(v(j), vbLowerCase)
If Not IsError(Application.Match(v(j), a, 0)) Then v(j) = StrConv(v(j), vbProperCase)
Next j
Capital = Join(v, " ")
End Function
Added UDF that parses HTML code, used the Sub Test above as UDF Capital and UDF to bring together. Welcome suggestions to make it cleaner or more efficient
Dim rng As Range, cell As Range
Set rng = Range("A1:A5")
' Define the pattern
Dim pattern As String: pattern = "*<h?>*</h?>*"
' Check each item against the pattern
For Each cell In rng
If (cell Like pattern = True) Then
cell.Offset(0, 16).Value = cell.Value
cell.Offset(0, 16).Value = joinCell(Capital(StripHTML(cell)), cell.Offset(0, 0).Value) 'used UDF for striping innertext, applying rules and joining back string
End If
Next cell
End Sub
I developed some code for an Access Database that manipulates a string with a statement like:
myString = Left(myString, somePosition) & Right(myString, someOtherPosition)
the above is part of a loop that has thousands of iterations and the variable myString is thousand of characters long.
I know the above code is bad practice in Java and a StringBuffer should be used instead of a string.
My code is taking a lot of time to run (about 7 minutes) and I suspect the problem might be related to the heavy string manipulation that is going on. Can you please confirm if there is anything similar to StringBuffer in VBA that could improve the efficiency of my code?
Update: full code with StringBuilder
Function SelectColumns2(str As String, columns As String, separator As String) As String
'column_number is the number of the column we are reading when we loop through a line
'z is the counter of the field (a portion of str between two separators)
'i is the counter of the str (the position of the modified string)
Dim column_number As Integer, i As Double, z As Integer, leftPosition As Double
'stringbuilder that stores the string that will represent the final file
Dim sb As StringBuilder, leftStr As StringBuilder, rightStr As StringBuilder
Set sb = New StringBuilder
Set leftStr = New StringBuilder
Set rightStr = New StringBuilder
sb.Append str
column_number = 1
i = 1 ' full str
z = 0 ' full field
While sb.Length >= i
z = z + 1
If Mid(sb.Text, i, 1) = separator Then
If InStr(1, columns, "/" & column_number & "/") = 0 Then
leftStr.Append left(sb.Text, i - z)
rightStr.Append right(sb.Text, sb.Length - i)
sb.Clear
sb.Append leftStr.Text
sb.Append rightStr.Text
leftStr.Clear
rightStr.Clear
i = i - z
End If
column_number = column_number + 1
z = 0
ElseIf Mid(sb.Text, i, 1) = Chr(10) Then
If InStr(1, columns, "/" & column_number & "/") = 0 Then
leftPosition = max((i - z - 1), 0)
If leftPosition = 0 Then
leftStr.Append left(sb.Text, leftPosition)
rightStr.Append right(sb.Text, sb.Length - i)
sb.Clear
sb.Append leftStr.Text
sb.Append rightStr.Text
Else
leftStr.Append left(sb.Text, leftPosition)
rightStr.Append right(sb.Text, sb.Length - i + 1)
sb.Clear
sb.Append leftStr.Text
sb.Append rightStr.Text
End If
leftStr.Clear
rightStr.Clear
i = i - z
End If
column_number = 1
z = 0
End If
i = i + 1
Wend
SelectColumns2 = left(sb.Text, sb.Length - 1)
End Function
You can use CreateObject to create the .Net stringbuilder class. Note that you will have to have the relevant .Net library installed, and VBA does not support overloading, so it will handle a little differently than in VB.Net.
Sample code:
Public Sub TestSB()
Dim sb As Object
Set sb = CreateObject("System.Text.StringBuilder")
sb.Append_3 "Hello"
sb.Append_3 " "
sb.Append_3 "World"
sb.Append_3 "!"
Debug.Print sb.ToString
End Sub
Alternatively, you can build your own stringbuilder. This answer provides a stringbuilder class, and this question also shows some sample code.
You can - for an extremely simple implementation - use Mid.
For example, this code runs in about 0.1 ms for the quite large strings entered:
Public Function ChopString() As String
Dim Source As String
Dim LeftPart As Long
Dim RightPart As Long
Dim Result As String
Source = String(100000, "x")
LeftPart = 30000
RightPart = 40000
Result = Space(LeftPart + RightPart)
Mid(Result, 1) = Left(Source, LeftPart)
Mid(Result, 1 + LeftPart) = Right(Source, RightPart)
ChopString = Result
End Function
For smaller strings of a few K, it runs way faster.
Does anyone have a short script in VBscript for transposing a Matrix (given as CSV (comma separated values) file)?
A, 1, 2, 3
B, 7, 5, 6
->
A, B
1, 7
2, 5
3, 6
Many Thanks in advance
Tom
So by creating dynamic arrays and auto-increment their growth in parallel with discovering new columns of the original matrix, you can auto build the new data structure quite quickly.
Const OutputCSV = "C:\op.csv"
Dim dt_start, WriteOutput : dt_start = Now
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim file : Set file = fso.OpenTextFile("C:\test.csv", 1, True)
Set WriteOutput = fso.OpenTextFile(OutputCSV, 8, True)
Dim fc : fc = file.ReadAll : file.close : Dim fcArray : fcArray = Split(fc, vbCrLf)
WScript.echo "Before Transpose"
WScript.echo "----------------"
WScript.echo fc
WScript.echo "----------------"
Dim opArray() : ReDim opArray(0)
For Each row In fcArray
Dim tmp: tmp = Split(row, ",")
For ent=0 To UBound(tmp)
If ent > UBound(opArray) Then
ReDim Preserve opArray(UBound(opArray)+1)
opArray(ent) = Trim(tmp(ent))
Else
If Len(opArray(ent)) > 0 Then
opArray(ent) = opArray(ent) & "," & Trim(tmp(ent))
Else
opArray(ent) = Trim(tmp(ent))
End If
End If
Next
Next
Dim dt_end : dt_end = Now
WScript.echo "After Transpose"
WScript.echo "----------------"
WScript.echo Join(opArray, vbCrLf)
WScript.echo "----------------"
WScript.echo "Script Execution Time (sec): " & DateDiff("s", dt_start, dt_end)
WriteOutput.Write Join(opArray, vbCrLf) : WriteOutput.Close
If it's just two lines with an equal number of values, you can read both into arrays using the Split function:
a1 = Split(FileIn.ReadLine, ",")
a2 = Split(FileIn.ReadLine, ",")
Then, iterate the arrays and write each element:
For i = 0 To UBound(a1)
FileOut.WriteLine a1(i) & ", " & a2(i)
Next
I'm assuming you know how to open files for reading and writing?
Edit: It sounds like you may have an unknown number of rows to read. In that case, you can use an array of arrays:
Dim a(255) ' Hold up to 255 rows. Adjust as needed. Or use ReDim Preserve to grow dynamically.
Do Until FileIn.AtEndOfStream
a(i) = Split(FileIn.ReadLine, ",")
i = i + 1
Loop
Then, to write:
For j = 0 To UBound(a(0))
' Concatenate the elements into a single string...
s = ""
For k = 0 To i - 1
s = s & a(k)(j) & ","
Next
' Write the string without the final comma...
FileOut.WriteLine Left(s, Len(s) - 1)
Next
i need to get a list of all possible combinations, not permutations.
to make sure i have the right name, 123 and 321 to me are the same thing and should only be listed once.
the code below does what i need but i can't convert it into MS Access vba.
i'm sorry, i know this is basic and it has been asked a million times but i can't find anything for MS Access that works for me.
Sub test_print_nCr()
print_nCr 7, 3, Range("A1")
End Sub
2.
Public Function print_nCr(n As Integer, r As Integer, p As Range)
c = 1
internal_print_nCr n, r, p, 1, 1
End Function
3.
Public Function internal_print_nCr(n As Integer, r As Integer, ByVal p As Range, Optional i As Integer, Optional l As Integer) As Integer
' n is the number of items we are choosing from
' r is the number of items to choose
' p is the upper corner of the output range
' i is the minimum item we are allowed to pick
' l is how many levels we are in to the choosing
' c is the complete set we are working on
If n < 1 Or r > n Or r < 0 Then Err.Raise 1
If i < 1 Then i = 1
If l < 1 Then l = 1
If c < 1 Then c = 1
If r = 0 Then
p = 1
Exit Function
End If
Dim x As Integer
Dim y As Integer
For x = i To n - r + 1
If r = 1 Then
If c > 1 Then
For y = 0 To l - 2
If p.Offset(c - 1, y) = "" Then p.Offset(c - 1, y) = p.Offset(c - 2, y)
Next
End If
p.Offset(c - 1, l - 1) = x
c = c + 1
Else
p.Offset(c - 1, l - 1) = x
internal_print_nCr n, r - 1, p, x + 1, l + 1
End If
Next
End Function
thank you again
I am not sure if this is the best method to do this, but I would use a kind of binary representation. For instance, consider the word "boy" with the number of letters n=3. This word has three letters, so you can use something like this:
001 = y,
010 = o,
011 = oy,
100 = b,
101 = by,
110 = bo,
111 = boy.
The left side can be done with a loop from i=1 to power(2,n)-1 and transforming i to a number in the binary basis. So, the only thing you have to do is to use the non null positions to build your combinations.
Probably there is something more interesting than this in Knuth.
i found this code here, and it gives me exactly what i need. you just have to create a table with numbers from 1-100. instructions at the link below
enter link description here
thank you everyone
Public Sub buildquery(strN As String, K As Integer)
Dim qd As DAO.QueryDef
Dim intI As Integer
Dim strsql As String
Dim strSelect As String
Dim strFrom As String
Dim strWhere As String
Set qd = CurrentDb.QueryDefs("QN")
qd.sql = "SELECT N FROM tblN WHERE N IN (" & strN & ")"
Set qd = Nothing
strSelect = "SELECT QN.N "
strFrom = "FROM QN "
strWhere = "WHERE QN_1.N > QN.N "
For intI = 1 To K - 1
strSelect = strSelect & ", QN_" & intI & ".N AS N" & intI & " "
strFrom = strFrom & ", QN AS QN_" & intI & " "
If intI < K - 1 Then
strWhere = strWhere & " AND QN_" & intI + 1 & ".N > QN_" & intI & ".N "
End If
Next
strsql = strSelect & " INTO tblCombinations " & strFrom & strWhere
DoCmd.SetWarnings False
DoCmd.RunSQL strsql
DoCmd.SetWarnings True
End Sub
then test
Public Sub testbuildquery()
buildquery "1,2,3,4,5,6,7", 3
End Sub