I am using excel 2010.
I have the following vba function, which retrieves me currencies from yahoo finance. However, my problem is that I am using a German Version of Excel and the . is in this Version a ,.
Therefore the converted currencies look like that:
That is the function I am using:
Function MYCURRENCYEXCHANGER(SourceCur As String, DestCur As String) As Variant
Dim url As String
' http://quote.yahoo.com/d/quotes.csv?s=XXXYYY=X&f=l1 this is the link format where XXX is currency1 and YYY is currency2 '
url = "http://quote.yahoo.com/d/quotes.csv?s=" & SourceCur & DestCur & "=X&f=l1"
Dim myHTTP As New WinHttp.WinHttpRequest
myHTTP.Open "GET", url, False
myHTTP.send ""
If myHTTP.StatusText <> "OK" Then GoTo ServerErrorHandler
If Not (WorksheetFunction.IsNumber(myHTTP.responseText)) Then MYCURRENCYEXCHANGER = 0
MYCURRENCYEXCHANGER = CDbl(myHTTP.responseText)
Exit Function
ServerErrorHandler:
MsgBox "Error. Could not convert currency"
End Function
Any recommendation how to convert the currency correctly so that the . is replaced by a , when fetched from yahoo finance?
I apprecaite your replies!
You can use the function "Replace" to achieve this quite simply.
Function MYCURRENCYEXCHANGER(SourceCur As String, DestCur As String) As Variant
Dim url As String
' http://quote.yahoo.com/d/quotes.csv?s=XXXYYY=X&f=l1 this is the link format where XXX is currency1 and YYY is currency2 '
url = "http://quote.yahoo.com/d/quotes.csv?s=" & SourceCur & DestCur & "=X&f=l1"
Dim myHTTP As New WinHttp.WinHttpRequest
myHTTP.Open "GET", url, False
myHTTP.send ""
If myHTTP.StatusText <> "OK" Then GoTo ServerErrorHandler
Replace(myHTTP.StatusText, ".", ",")
If Not (WorksheetFunction.IsNumber(myHTTP.responseText)) Then MYCURRENCYEXCHANGER = 0
MYCURRENCYEXCHANGER = CDbl(myHTTP.responseText)
Exit Function
ServerErrorHandler:
MsgBox "Error. Could not convert currency"
End Function
The Replace(string, searchtext, replacetext) function will change all occurrences of searchtext by replacetext in your string.
I've not tested it but I'm fairly confident that this should do the trick.
Related
We import XML files into an Access database. This data includes a description column which can contain special characters like ä é etc. We use this database to export a table to our Financial programm. This programm can't handle these special characters. Therefore I would like to make a VBA function that can replace any special character within a specific table/colomn.
I am fairly new to using VBA, so I used Google a lot to try to find some background about this topic. I have found this code for Excel, and think this can be used in Access as well. However, I can't make the connection with the Update table function.
Function RemovePunctuation(Txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "[^A-Z0-9 ]"
.IgnoreCase = True
.Global = True
RemovePunctuation = .Replace(Txt, "")
End With
End Function
The Function above (RemovePunctuation) works with the Query in Access and returns a list with the values of the original table without any punctuation. I used the following Query:
SELECT RemovePunctuation([ColumnName]) AS [Add]
FROM TableName;
However, this returns a new table instead of replacing the values in the original table. Can information be shared on a different Query which uses the function to update originale table?
Cause I'm really new to this, I can't show much. I would expect the code to look like:
Function UpdateTable(Table As String, Column As String) As String
Update Table Set Column =
With CreateObject("VBScript.RegExp")
.Pattern = "[^A-Z0-9 ]"
.IgnoreCase = True
.Global = True
RemovePunctuation = .Replace(Txt, "")
End With
End Function
But this returns nothing.
Expected result should be returning spaces where special characters are in column selected.
As mentioned, code returns nothing so far as this isn't a valid function at all. Please advise.
In case the xml file is not linked, but indeed imported, you have full control of the imported data. You could create an additional table, where you have a field 'TableName' for each xml file, a field 'FieldName' for each column, a field 'CharIn' for each special character to validate and a field 'CharOut' for the replacing character. Then build code to walk through the imported data, and then search and replace based upon your new additional table. Replace is a default function, but you could write your own, something like
Function ReplaceString(strCaller As String, memText As Variant, strSearch As String, strReplace As String) As Variant
'Define variables
Dim dblPos As Double 'pointer in text
'Walk through the text, search and replace
dblPos = InStr(memText, strSearch)
Do While dblPos > 0
If Asc(strSearch) = Asc(Mid$(memText, dblPos, 1)) Then
memText = Left$(memText, dblPos - 1) + strReplace + Mid$(memText, dblPos + Len(strSearch))
dblPos = Abs(dblPos - Len(strSearch))
End If
dblPos = InStr(dblPos + 1, memText, strSearch)
Loop
ReplaceString = memText
Based on code provided by #jeroen jong, the question is answered. Provided code to replace special characters in any given table in Access is the following:
One module is made with the following code:
Option Compare Database
Option Explicit
Private Const strObject As String = "modConversion"
Function ReplaceString(strCaller As String, memText As Variant, strSearch As String,
strReplace As String) As Variant
On Error GoTo Err_Function
'Define variables
Dim strProcedure As String 'name of current procedure
Dim dblPos As Double 'pointer in text
'Initialise variables
strProcedure = "ReplaceString"
'Walk through the text, search and replace
dblPos = InStr(memText, strSearch)
Do While dblPos > 0
If Asc(strSearch) = Asc(Mid$(memText, dblPos, 1)) Then
memText = Left$(memText, dblPos - 1) + strReplace + Mid$(memText, dblPos + Len(strSearch))
dblPos = Abs(dblPos - Len(strSearch))
End If
dblPos = InStr(dblPos + 1, memText, strSearch)
Loop
ReplaceString = memText
Exit_Function:
Exit Function
Err_Function:
MsgBox Err.Number, Err.Description, Err.Source, strObject, strProcedure
ReplaceString = memText
Resume Exit_Function
End Function
One function is created the call the ReplaceString function. In this case it is called from a Form with a button:
Option Compare Database
Option Explicit
Private Const strObject As String = "frmReplace"
Private Sub cmdReplace_Click()
On Error GoTo Err_Sub
'Define variables
Dim strProcedure As String 'name of current procedure
Dim dbs As DAO.Database
Dim rsTable As DAO.Recordset
Dim rsReplace As DAO.Recordset
Dim strFieldName As String
'Initialise variables
strProcedure = "cmdReplace_Click"
'Initialise database and recordset
Set dbs = CurrentDb
Set rsReplace = dbs.OpenRecordset("tblReplace", dbReadOnly)
With rsReplace
Do While Not .EOF
'Open table
Set rsTable = dbs.OpenRecordset(!TableName, dbOpenDynaset)
'Walk through all records, and replace char in field
Do While Not rsTable.EOF
rsTable.Edit
rsTable(!FieldName) = ReplaceString(strProcedure, rsTable(!FieldName), !TextSearch, !TextReplace)
rsTable.Update
rsTable.MoveNext
Loop 'rsTable
.MoveNext
rsTable.Close
Loop 'rsReplace
.Close
End With
MsgBox "Replacement of special characters is completed", vbInformation, "Replace"
Exit_Sub:
On Error Resume Next
rsTable.Close
Set rsTable = Nothing
rsReplace.Close
Set rsReplace = Nothing
dbs.Close
Set dbs = Nothing
Exit Sub
Err_Sub:
MsgBox Err.Number & " - " & vbLf & Err.Description & " - " & vbLf & Err.Source, vbCritical, strObject & "-" & strProcedure
Resume Exit_Sub
End Sub
The table to provide data to search and replace consists of the following columns:
Id As Id;
TableName As String;
FieldName As String;
Replace As Boolean;
TextSearch As String;
TextReplace As String;
CaseSensitive As Boolean;
Again thanks for solving my question!
I have done some research and haven't found any similar question.
I have a VBA macro that imports a .CSV file containing telegrams sent by a device.
In the end of this macro, I want to create a graph with the time elapsed on the x-axis and the value corresponding to the telegram.
The issue is that this value can be of different types: hexadecimal, boolean, integer... And that they don't respect the standard Excel number format, which means that they can't be used to create a graph.
Here are some examples (with " around the value to show its start and end) :
hexadecimal : "A7 C8"
Boolean : "$00" or ""$01"
Percentage : "$30"
And here is an example of data, with custom time format and boolean value
Here is my related code so far, where I try to convert into a custom type then convert back to numeric to get a common number datatype :
If wsRes.Range("R1").Value Like "$##" Then
wsRes.Range("R1:R" & plotLine).NumberFormat = "$##"
wsRes.Range("R1:R" & plotLine).NumberFormat = General
End If
If wsRes.Range("R1").Value Like "??[ ]??" Then
Dim valArray(1) As String
For i = 1 To plotLine Step 1
valArray = Split(wsRes.Range("R" & i), " ")
wsRes.Range("R" & i).Value = ToInt32(valArray(0) + valArray(1), 16)
wsRes.Range("" & i).NumberFormat = General
Next i
End If
I haven't been able to test it with hexa yet, but the conversion trick doesn't work with percentage/boolean
EDIT :
First, thank you for your answers.
Here is my final code for anyone's interested, adapted from Vityata's.
This method will allow to easily add other datatypes if needed.
Sub TestMe()
Dim RangeData as String
Set wsRes = ActiveWorkbook.Sheets("Results")
For i = 1 To plotLine Step 1 'plotLine is the last line on which I have data
DetectType wsRes.Range("R" & i).Value, i
Next i
RangeData = "Q1:R" & plotLine
CreateGraph RangeData 'Call My sub creating the graph
End Sub
Public Sub DetectType(str As String, i As Integer)
Select Case True
Case wsRes.Range("R" & i).Value Like "??[ ]??"
wsRes.Range("R" & i).Value = HexValue(str)
Case wsRes.Range("R" & i).Value Like "?##"
wsRes.Range("R" & i).Value = DecValue(str)
Case Else
MsgBox "Unsupported datatype detected : " & str
End
End Select
End Sub
Public Function HexValue(str As String) As Long
Dim valArray(1) As String 'Needed as I have a space in the middle that prevents direct conversion
valArray(0) = Split(str, " ")(0)
valArray(1) = Split(str, " ")(1)
HexValue = CLng("&H" & valArray(0) + valArray(1))
End Function
Public Function DecValue(str As String) As Long
DecValue = Right(str, 2)
End Function
You need three boolean functions, following your business logic and some of the Clean Code principles (although the author of the book does not recognize VBA people as programmers):
IsHex()
IsBoolean()
IsPercentage()
Public Sub TestMe()
Dim myInput As Variant
myInput = Array("A7C8", "$01", "$30")
Dim i As Long
For i = LBound(myInput) To UBound(myInput)
Debug.Print IsHex(myInput(i))
Debug.Print IsBoolean(myInput(i))
Debug.Print IsPercentage(myInput(i))
Debug.Print "-------------"
Next i
'or use this with the DetectType() function below:
'For i = LBound(myInput) To UBound(myInput)
' Debug.Print DetectType(myInput(i))
'Next i
End Sub
Public Function IsHex(ByVal str As String) As Boolean
On Error GoTo IsHex_Error
IsHex = (WorksheetFunction.Hex2Dec(str) <> vbNullString)
On Error GoTo 0
Exit Function
IsHex_Error:
End Function
Public Function IsBoolean(ByVal str As String) As Boolean
IsBoolean = CBool((str = "$00") Or (str = "$01"))
End Function
Public Function IsPercentage(ByVal str As String) As Boolean
IsPercentage = (Len(str) = 3 And Left(str, 1) = "$" And IsNumeric(Right(str, 2)))
End Function
Then some additional logic is needed, because $01 is both Boolean and Percentage. In this case, you can consider it Percentage. This is some kind of a mapper, following this business logic:
Public Function DetectType(str) As String
Select Case True
Case IsHex(str)
DetectType = "HEX!"
Case IsPercentage(str) And IsBoolean(str)
DetectType = "Boolean!"
Case IsPercentage(str)
DetectType = "Percentage!"
Case Else
DetectType = "ELSE!"
End Select
End Function
I'm trying to delete string content before a certain word contained within the string. For example
master_of_desaster#live.de
I'd like to use VBA in order to replace that with
master_of_desaster
Everything after the "word" (#) should be removed, including the "word" itself.
I found a similar topic here, but he asks the opposite.
email = "master_of_desaster#live.de"
ret = Left(email, InStr(1, email, "#") - 1)
Result: master_of_desaster
Thanks to Shai Rado
=split("master_of_desaster#live.de","#")(0)
Just for fun - a regex approach.
Public Sub reg()
Dim re_pattern As String
Dim re As RegExp
Dim email As String
Dim match As Object
Set re = New RegExp
email = "master_of_desaster#live.de"
re_pattern = "(.*)#.*"
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = re_pattern
End With
Set match = re.Execute(email)
Debug.Print match.Item(0).SubMatches(0)
End Sub
A bit hacky but fast ( most Windows API accept zero terminated strings )
ret = Replace("master_of_disaster#live.de", "#", vbNullChar, , 1) ' Chr(0)
I usually use the Split method but with Limit:
ret = Split("master_of_disaster#live.de", "#", 2)(0)
ret = evaluate("left(" & string & ", search(""#"", " & string & ") - 1)")
I am trying to remove words appearing in one string from a different string using a custom function. For instance:
A1:
the was why blue hat
A2:
the stranger wanted to know why his blue hat was turning orange
The ideal outcome in this example would be:
A3:
stranger wanted to know his turning orange
I need to have the cells in reference open to change so that they can be used in different situations.
The function will be used in a cell as:
=WORDREMOVE("cell with words needing remove", "cell with list of words being removed")
I have a list of 20,000 rows and have managed to find a custom function that can remove duplicate words (below) and thought there may be a way to manipulate it to accomplish this task.
Function REMOVEDUPEWORDS(txt As String, Optional delim As String = " ") As String
Dim x
'Updateby20140924
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each x In Split(txt, delim)
If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
Next
If .Count > 0 Then REMOVEDUPEWORDS = Join(.keys, delim)
End With
End Function
If you can guarantee that your words in both strings will be separated by spaces (no comma, ellipses, etc), you could just Split() both strings then Filter() out the words:
Function WORDREMOVE(ByVal strText As String, strRemove As String) As String
Dim a, w
a = Split(strText) ' Start with all words in an array
For Each w In Split(strRemove)
a = Filter(a, w, False, vbTextCompare) ' Remove every word found
Next
WORDREMOVE = Join(a, " ") ' Recreate the string
End Function
You can also do this using Regular Expressions in VBA. The version below is case insensitive and assumes all words are separated only by space. If there is other punctuation, more examples would aid in crafting an appropriate solution:
Option Explicit
Function WordRemove(Str As String, RemoveWords As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.ignorecase = True
.Global = True
.Pattern = "(?:" & Join(Split(WorksheetFunction.Trim(RemoveWords)), "|") & ")\s*"
WordRemove = .Replace(Str, "")
End With
End Function
My example is certainly not the best code, but it should work
Function WORDREMOVE(FirstCell As String, SecondCell As String)
Dim FirstArgument As Variant, SecondArgument As Variant
Dim FirstArgumentCounter As Integer, SecondArgumentCounter As Integer
Dim Checker As Boolean
WORDREMOVE = ""
FirstArgument = Split(FirstCell, " ")
SecondArgument = Split(SecondCell, " ")
For SecondArgumentCounter = 0 To UBound(SecondArgument)
Checker = False
For FirstArgumentCounter = 0 To UBound(FirstArgument)
If SecondArgument(SecondArgumentCounter) = FirstArgument(FirstArgumentCounter) Then
Checker = True
End If
Next FirstArgumentCounter
If Checker = False Then WORDREMOVE = WORDREMOVE & SecondArgument(SecondArgumentCounter) & " "
Next SecondArgumentCounter
WORDREMOVE = Left(WORDREMOVE, Len(WORDREMOVE) - 1)
End Function
I've stumbled upon a compile error, but don't get what can be of the issue. When trying to chagne the symbol to an input variable ( TickerID ) I get the error, works perfectly fine otherwise when inputting e.g "yhoo" for the yahoo ticker name.
Code
Private Sub CmdBtn_Add_Click()
'---------------------------------------------------------------------------------------'
' Checks that inputted ticker name is correct and calls import class after confirmation
'---------------------------------------------------------------------------------------'
' General Variables---------'
Dim TickerID As String: TickerID = UCase(Add_Instrument.TxtBox_Instrument.Value)
'--------------------------'
'Check if input field is not empty
If TickerID = "" Or Application.WorksheetFunction.IsText(TickerID) = False Then
MsgBox "Please provide a valid ticker ID"
Exit Sub
End If
Debug.Print TickerID
'Check Ticker name exists through YQLBuilder class
Dim YQLBuilder As YQLBuilder: Set YQLBuilder = New YQLBuilder
Call YQLBuilder.TickerCheck(TickerID)
' Call ImportData(TickerID)
' MsgBox "Please check the ticker name. It is in the wrong format"
End Sub
Public Sub TickerCheck(TickerID As String)
'---------------------------------------------------------------------------------------'
' Built 2014-11-05 Allows parsing of XML data through YAHOO API YQL
' 2014-12-21: Not fully built yet, see where it can be of use
'---------------------------------------------------------------------------------------'
' General Variables---------'
Const ConnStringStart As String = "http://query.yahooapis.com/v1/public/yql?q="
Const ConnStringLast As String = "&diagnostics=true&env=store://datatables.org/alltableswithkeys"
'---------------------------'
Const ConnStringInput As String = "select * from yahoo.finance.stocks where symbol='" _
& TickerID & "'" **<----- Error here!**
Debug.Print ConnStringStart & ConnStringInput & ConnStringLast
Dim YQLNodes As MSXML2.IXMLDOMNodeList
Dim YQLReq As MSXML2.DOMDocument60
Set YQLReq = New MSXML2.DOMDocument60
YQLReq.async = False
YQLReq.Load ConnStringStart & ConnStringInput & ConnStringLast
YQLReq.setProperty "SelectionNamespaces", "xmlns:f='http://www.yahooapis.com/v1/base.rng'"
Set YQLNodes = YQLReq.SelectNodes("//CompanyName")
Dim xNode As MSXML2.IXMLDOMNode
For Each xNode In YQLNodes
Debug.Print xNode.Text
Next xNode
Debug.Print YQLNodes.Length
End Sub
The message is clear. When you declare a constant, the value you give it must be constant too. In this case, part of it is the parameter TickerId, which is variable. You cannot declare a constant with a variable value.
To solve this, I think you could just use Dim instead of Const and not make ConnStringInput a constant at all.