I have a search form I creating in access with a code to search for keywords and then create a table with the results:
Like"*"&[FORMS]![Search_Form]![KW_Text]&"*"
WHich basically tells it to read the keyword i type in and pull up any matching results.
I would like to be able to type in multiple words, in the table containing all the data I have multiple keywords for each bit of data all separated by comas. So if I type in Manager it returns all results with the word Manager in it, I would like to be able to type in Manager, Supervisor and have it return all results for manager and all results for supervisor.
You can use the SPLIT() function in VBA to split the search string into an array, then For Each through the array to build up a search/filter string such as
(thing LIKE "*Manager*") OR (thing LIKE "*Supervisor*")
I use this code. It create a OR between your sting separated by a space. I put this processed string in an querydefs
Function CreateOr(MyCriteria As String, MyField As String) As String
Dim MyChar As String
Dim MyUniqueCriteria As String
Dim MyFinalCriteria As String
Dim I, j As Integer
j = 0
For I = 1 To Len(MyCriteria)
MyChar = Mid(MyCriteria, I, 1)
If MyChar = " " Then
If j = 0 Then
MyFinalCriteria = MyFinalCriteria & MyField & "=" & MyUniqueCriteria
Else
MyFinalCriteria = MyFinalCriteria & " or " & MyField & "=" & MyUniqueCriteria
End If
MyUniqueCriteria = ""
j = j + 1
Else
MyUniqueCriteria = MyUniqueCriteria & MyChar
End If
Next
CreateOr = MyFinalCriteria
End Function
Hope it help you
Related
I'm just starting to work with JSON in one of my macros. I'm able to send a call to an API service and it returns results. The service has been set up to return something like 25 fields (?). I don't need all of the fields, just some of them. The macro uses VBA.
I'm able to write the results to a specific worksheet with the following code:
For Each result In jsonObject
With Sheets("Sheet1")
.Cells(r, 5).Value = result("firstName")
.Cells(r, 6).Value = result("lastName")
.Cells(r, 9).Value = result("userCodeInfo")("userCode")
.Cells(r, 10).Value = result("userCodeInfo")("previousUserCode")
.Cells(r, 28).Value = result("saleType")
.Cells(r, 29).Value = result("cost")
End With
Next
Later, in the code, a decision point needs to use to one of the fields in the results. I'm trying to use a function to return that field value:
Public Function APIUnitData_Read(MyField As String)
Dim JSONConverter As New clsJSONParser
Set jsonObject = JSONConverter.ParseJson(UnitResp)
For Each result In jsonObject
APIUnitData_Read = result(MyField)
Next
End Function
The function works well when the field is a "non-grouped" field, e.g., "firstName, "lastName", etc.
vDecPt = API.APIUnitData_Read("firstName")
It doesn't work (or at least I haven't gotten it to work with the "grouped" fields; e.g., ("userCodeInfo")("userCode") and ("userCodeInfo")("previousUserCode").
vDecPt = API.APIUnitData_Read("userCodeInfo")("PreviousUseCode")
I'm guessing I don't have the right combination of parentheses, double quotes, single quotes, etc. I've tried a number of different combinations without success. I'm sure my lack of experience is also in play here.
Any suggestions or advice how to resolve this issue would be greatly appreciated. Thanks for taking the time to review this question and for any help you can provide......
If you're asking about accessing nested values with a single call then maybe you can try something like this:
Sub tester()
Dim json As Object
Set json = JsonConverter.ParseJson(JsonContent)
Debug.Print JSONValue(json, "name") ' fred
Debug.Print JSONValue(json, "addresses/1/city") ' NYC
Debug.Print JSONValue(json, "addresses/2/street") ' Rue blah
Debug.Print JSONValue(json, "values/4") ' 40
End Sub
'return a "leaf" value from a `json` object
Public Function JSONValue(json As Object, MyField As String)
Dim res, arr, i, v
Set res = json
arr = Split(MyField, "/") 'array of keys/indexes
For i = LBound(arr) To UBound(arr)
v = arr(i)
If TypeName(res) = "Collection" Then v = CLng(v) 'numeric index for collection
If i <> UBound(arr) Then
'not at the end yet so have either a dictionary or a collection
Set res = res(v)
Else
'accessing a single non-object value
JSONValue = res(v)
End If
Next i
End Function
'dummy JSON content
Function JsonContent()
JsonContent = Replace("{'name':'fred','addresses':" & _
"[{'city':'NYC','street':'Easy St'}," & _
"{'city':'Paris','street':'Rue blah'}]," & _
"'values':[10,20,30,40]}", "'", """")
End Function
Very basic but should work if you just want a single non-object return value which might be nested several fields deep.
I'm consuming a web service in some legacy applications written in VB6. Right now I've been able to parse the JSON returned from a web service using the VB JSON parser found here: http://www.ediy.co.nz/vbjson-json-parser-library-in-vb6-xidc55680.html
However, I'm still hardcoding the JSON string that gets passed into the POST request payload.
Generically speaking:
result = WebRequestPost(url, "{""Id"":""" & productId & """,""Name"":""" & productName & """,""Category"":""" & productCat & """,""Price"":""" & productPrice & """}")
Is there a cleaner way that I can generate a JSON payload based on an object?
I ended up building my own assembler of sorts...
Dim jsonArray() As String
'_______________________________________________________________
'Initializes the opening and closing braces of the JSON payload
Public Sub JSONInitialize()
ReDim jsonArray(1)
jsonArray(0) = "{"
jsonArray(1) = "}"
End Sub
'_______________________________________________________________
'Adds a string value to the JSON payload
Public Sub JSONAddString(nFieldName As String, nValue As String)
Dim temp As String
temp = jsonArray(UBound(jsonArray))
Dim index As Integer
index = UBound(jsonArray)
ReDim Preserve jsonArray(UBound(jsonArray) + 1)
jsonArray(UBound(jsonArray)) = temp
jsonArray(index) = """" & nFieldName & """:""" & nValue & ""","
End Sub
'_______________________________________________________________
'Adds an integer value to the JSON payload
Public Sub JSONAddInt(nFieldName As String, nValue As Integer)
Dim temp As String
temp = jsonArray(UBound(jsonArray))
Dim index As Integer
index = UBound(jsonArray)
ReDim Preserve jsonArray(UBound(jsonArray) + 1)
jsonArray(UBound(jsonArray)) = temp
jsonArray(index) = """" & nFieldName & """:" & nValue & ","
End Sub
So (sanitized) execution ends up looking like:
Dim o As New MyObject
Call o.JSONInitialize
Call o.JSONAddString("My JSON String Field", "Test String Value")
Call o.JSONAddInt("My JSON Int Field", 25)
o.JSONSerialize() returns:
{"My JSON String Field":"Test String Value","My JSON Int Field": 25,}
Unfortunately it puts the comma at the end so it won't win any beauty contests but the API I'm calling doesn't care.
Is there a way of taking html code for a table and printing out the same table in a word document using VBA (VBA should be able to parse the html code block for a table)?
It is possible to take the contents of the table and copy them into a new table created in Word, however is it possible to recreate a table using the html code and vba?
For any of this, where can one begin to research?
EDIT:
Thanks to R3uK: here is the first portion of the VBA script which reads a line of html code from a file and uses R3uK's code to print it to the excel worksheet:
Private Sub button1_Click()
Dim the_string As String
the_string = Trim(ImportTextFile("path\to\file.txt"))
' still working on removing new line characters
Call PrintHTML_Table(the_string)
End Sub
Public Function ImportTextFile(strFile As String) As String
' http://mrspreadsheets.com/1/post/2013/09/vba-code-snippet-22-read-entire-text-file-into-string-variable.html
Open strFile For Input As #1
ImportTextFile = Input$(LOF(1), 1)
Close #1
End Function
' Insert R3uK's portion of the code here
This could be a good place to start, you will only need to check content after to see if there is any problem and then copy it to word.
Sub PrintHTML_Table(ByVal StrTable as String)
Dim TA()
Dim Table_String as String
Table_String = " " & StrTable & " "
TA = SplitTo2DArray(Table_String, "</tr>", "</td>")
For i = LBound(TA, 1) To UBound(TA, 1)
For j = LBound(TA, 2) To UBound(TA, 2)
ActiveSheet.Cells(i + 1, j + 1) = Trim(Replace(Replace(TA(i, j), "<td>", ""), "<tr>", ""))
Next j
Next i
End Sub
Public Function SplitTo2DArray(ByRef StringToSplit As String, ByRef RowSep As String, ByRef ColSep As String) As String()
Dim Rows As Variant
Dim rowNb As Long
Dim Columns() As Variant
Dim i As Long
Dim maxlineNb As Long
Dim lineNb As Long
Dim asCells() As String
Dim j As Long
' Split up the table value by rows, get the number of rows, and dim a new array of Variants.
Rows = Split(StringToSplit, RowSep)
rowNb = UBound(Rows)
ReDim Columns(0 To rowNb)
' Iterate through each row, and split it into columns. Find the maximum number of columns.
maxlineNb = 0
For i = 0 To rowNb
Columns(i) = Split(Rows(i), ColSep)
lineNb = UBound(Columns(i))
If lineNb > maxlineNb Then
maxlineNb = lineNb
End If
Next i
' Create a 2D string array to contain the data in <Columns>.
ReDim asCells(0 To maxlineNb, 0 To rowNb)
' Copy all the data from Columns() to asCells().
For i = 0 To rowNb
For j = 0 To UBound(Columns(i))
asCells(j, i) = Columns(i)(j)
Next j
Next i
SplitTo2DArray = asCells()
End Function
I'm trying to set up a code in MS Access that increments the last four positions of a text field. The numbers in the text field have seven digits. For example:
0010012
0010013
First three digits represent the manuacturer and the last four the product. These are the ones I want to increment. I am using the code below, which I found online, and it is supposed to be working but I keep getting the error: "Run-time error '13': Type mismatch"
Dim varSifra As Variant
varSifra = DMax("[Sifra]", "tblProducts", "[Manufacturer] = " & Forms!frmProduct!Manufacturer)
Me.[Sifra] = Left(varSifra, 3) & Format(Val(Right(varSifra, 4)) + 1, "0000")
I tried the code without the Format function but instead of incremented number 0010014 I get 00114
Can this help?
Sub Test()
Debug.Print IncrementProduct("0010001") //Prints 0010002
Debug.Print IncrementProduct("0010012") //Prints 0010013
Debug.Print IncrementProduct("0010099") //Prints 0010100
End Sub
Function IncrementProduct(code As String) As String
Dim manufacturerCode As String, padding As String, productCode As String
manufacturerCode = VBA.Left$(code, 3)
productCode = CInt(VBA.Right$(code, Len(code) - Len(manufacturerCode))) + 1
padding = Application.WorksheetFunction.Rept("0", 4 - Len(productCode))
IncrementProduct = manufacturerCode & padding & productCode
End Function
You can use a simple Format call fine, however the input needs to be explicitly converted to a Long first:
Function IncProductNumber(Value)
If IsNull(Value) Then
Let IncProductNumber = Null
Else
Let IncProductNumber = Format(CLng(Value) + 1, "0000000")
End If
End Function
Or, more generically, the desired padding could be inferred from the input:
Function IncTextNumber(Value)
If IsNull(Value) Then
Let IncTextNumber = Null
Else
Let IncTextNumber = Format(CLng(Value) + 1, String$(Len(Value), "0"))
End If
End Function
IncTextNumber("0123") will produce "0124", IncTextNumber("00999") will produce "01000" and so on.
Dim tempManProd As String, tempNumToInc As Integer
tempManProd = 'get the value you are wanting to increment
tempNumToInc = CInt(right(tempManProd, 4))
tempNumToInc = tempNumToInc + 1
'This will make sure that the 0s get added back to the front of the product
Do While (Len(tempManProd & "") + Len(tempNumToInc & "")) < 7
tempManProd = tempManProd & "0"
Loop
tempManProd = tempManProd & CStr(tempNumToInc)
So I was wondering, how can I return multiple values from a function, sub or type in VBA?
I've got this main sub which is supposed to collect data from several functions, but a function can only return one value it seems. So how can I return multiple ones to a sub?
You might want want to rethink the structure of you application, if you really, really want one method to return multiple values.
Either break things apart, so distinct methods return distinct values, or figure out a logical grouping and build an object to hold that data that can in turn be returned.
' this is the VB6/VBA equivalent of a struct
' data, no methods
Private Type settings
root As String
path As String
name_first As String
name_last As String
overwrite_prompt As Boolean
End Type
Public Sub Main()
Dim mySettings As settings
mySettings = getSettings()
End Sub
' if you want this to be public, you're better off with a class instead of a User-Defined-Type (UDT)
Private Function getSettings() As settings
Dim sets As settings
With sets ' retrieve values here
.root = "foo"
.path = "bar"
.name_first = "Don"
.name_last = "Knuth"
.overwrite_prompt = False
End With
' return a single struct, vb6/vba-style
getSettings = sets
End Function
You could try returning a VBA Collection.
As long as you dealing with pair values, like "Version=1.31", you could store the identifier as a key ("Version") and the actual value (1.31) as the item itself.
Dim c As New Collection
Dim item as Variant
Dim key as String
key = "Version"
item = 1.31
c.Add item, key
'Then return c
Accessing the values after that it's a breeze:
c.Item("Version") 'Returns 1.31
or
c("Version") '.Item is the default member
Does it make sense?
Ideas :
Use pass by reference (ByRef)
Build a User Defined Type to hold the stuff you want to return, and return that.
Similar to 2 - build a class to represent the information returned, and return objects of that class...
You can also use a variant array as the return result to return a sequence of arbitrary values:
Function f(i As Integer, s As String) As Variant()
f = Array(i + 1, "ate my " + s, Array(1#, 2#, 3#))
End Function
Sub test()
result = f(2, "hat")
i1 = result(0)
s1 = result(1)
a1 = result(2)
End Sub
Ugly and bug prone because your caller needs to know what's being returned to use the result, but occasionally useful nonetheless.
A function returns one value, but it can "output" any number of values. A sample code:
Function Test (ByVal Input1 As Integer, ByVal Input2 As Integer, _
ByRef Output1 As Integer, ByRef Output2 As Integer) As Integer
Output1 = Input1 + Input2
Output2 = Input1 - Input2
Test = Output1 + Output2
End Function
Sub Test2()
Dim Ret As Integer, Input1 As Integer, Input2 As Integer, _
Output1 As integer, Output2 As Integer
Input1 = 1
Input2 = 2
Ret = Test(Input1, Input2, Output1, Output2)
Sheet1.Range("A1") = Ret ' 2
Sheet1.Range("A2") = Output1 ' 3
Sheet1.Range("A3") = Output2 '-1
End Sub
you can return 2 or more values to a function in VBA or any other visual basic stuff but you need to use the pointer method called Byref. See my example below. I will make a function to add and subtract 2 values say 5,6
sub Macro1
' now you call the function this way
dim o1 as integer, o2 as integer
AddSubtract 5, 6, o1, o2
msgbox o2
msgbox o1
end sub
function AddSubtract(a as integer, b as integer, ByRef sum as integer, ByRef dif as integer)
sum = a + b
dif = b - 1
end function
Not elegant, but if you don't use your method overlappingly you can also use global variables, defined by the Public statement at the beginning of your code, before the Subs.
You have to be cautious though, once you change a public value, it will be held throughout your code in all Subs and Functions.
I always approach returning more than one result from a function by always returning an ArrayList. By using an ArrayList I can return only one item, consisting of many multiple values, mixing between Strings and Integers.
Once I have the ArrayList returned in my main sub, I simply use ArrayList.Item(i).ToString where i is the index of the value I want to return from the ArrayList
An example:
Public Function Set_Database_Path()
Dim Result As ArrayList = New ArrayList
Dim fd As OpenFileDialog = New OpenFileDialog()
fd.Title = "Open File Dialog"
fd.InitialDirectory = "C:\"
fd.RestoreDirectory = True
fd.Filter = "All files (*.*)|*.*|All files (*.*)|*.*"
fd.FilterIndex = 2
fd.Multiselect = False
If fd.ShowDialog() = DialogResult.OK Then
Dim Database_Location = Path.GetFullPath(fd.FileName)
Dim Database_Connection_Var = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=""" & Database_Location & """"
Result.Add(Database_Connection_Var)
Result.Add(Database_Location)
Return (Result)
Else
Return (Nothing)
End If
End Function
And then call the Function like this:
Private Sub Main_Load()
Dim PathArray As ArrayList
PathArray = Set_Database_Path()
My.Settings.Database_Connection_String = PathArray.Item(0).ToString
My.Settings.FilePath = PathArray.Item(1).ToString
My.Settings.Save()
End Sub
you could connect all the data you need from the file to a single string, and in the excel sheet seperate it with text to column.
here is an example i did for same issue, enjoy:
Sub CP()
Dim ToolFile As String
Cells(3, 2).Select
For i = 0 To 5
r = ActiveCell.Row
ToolFile = Cells(r, 7).Value
On Error Resume Next
ActiveCell.Value = CP_getdatta(ToolFile)
'seperate data by "-"
Selection.TextToColumns Destination:=Range("C3"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Cells(r + 1, 2).Select
Next
End Sub
Function CP_getdatta(ToolFile As String) As String
Workbooks.Open Filename:=ToolFile, UpdateLinks:=False, ReadOnly:=True
Range("A56000").Select
Selection.End(xlUp).Select
x = CStr(ActiveCell.Value)
ActiveCell.Offset(0, 20).Select
Selection.End(xlToLeft).Select
While IsNumeric(ActiveCell.Value) = False
ActiveCell.Offset(0, -1).Select
Wend
' combine data to 1 string
CP_getdatta = CStr(x & "-" & ActiveCell.Value)
ActiveWindow.Close False
End Function