I have a URL that returns a ton of information that I need to break apart into rows/columns etc.
So far I have been able to get the .responsetext and then use Split to break it down, but I'm wondering best approach for getting this data onto spreadsheet as I'm about to do more "Split" and I feel like there is a better way using perhaps Arrays?
Macro:
Sub TEstHTML()
Dim URLStr As String
URLStr = "PrivateURL"
'< VBE > Tools > References > Microsoft Scripting Runtime & Microsoft XML, V6.0
Dim xhr As MSXML2.XMLHTTP60
Dim table As MSHTML.HTMLTable
Dim tableCells As MSHTML.IHTMLElementCollection
Set xhr = New MSXML2.XMLHTTP60
With xhr
.Open "GET", URLStr, False
.send
If .readyState = 4 And .status = 200 Then
Set doc = New MSHTML.HTMLDocument
doc.body.innerHTML = .responseText
Debug.Print doc.body.innerHTML
Stop
Else
Debug.Print "Error" & vbNewLine & "Ready state: " & .readyState & vbNewLine & "HTTP request status: " & .status
End If
End With
Dim SplitArr() As String
SplitArr = Split(doc.body.innerHTML, "{")
Debug.Print SplitArr(1)
Stop
End Sub
The page sends back a lot of data formatted like so:
{"ClientCode":"CLICODE","ClientName":"MyClient","ContractNumber":"2021-1",...}
Which the Split function returns:
"ClientCode":"CLICODE","ClientName":"MyClient","ContractNumber":"2021-1",...
I need to turn this into Colum Headers ClientCode & ClientName & ContractNumber and then paste the values one SplitArr(i) at a time. Note there are many column headers I'd like this to not be hardcoded ideally, but if needed I can make the column headers and then paste information somehow.
Update:
I'm not sure if I'm doing it wrong, or this data is/isn't JSON but this tool works great. I did have to make a function to "clean" the strings though. Here is what I ended up with..
Sub Testing()
Dim URLStr As String
URLStr = "URL"
Dim HTMLDoc As MSHTML.HTMLDocument
Set HTMLDoc = New MSHTML.HTMLDocument
Set HTMLDoc = Get_HTMLDocument(URLStr)
Dim HTMLDocStr As String
HTMLDocStr = HTMLDoc.body.innerHTML
HTMLDocStr = ConvertToJsonClear(HTMLDocStr)
Dim SplitArr() As String, Parsed As Dictionary, k, l As Long
SplitArr = Split(HTMLDocStr, "{")
For X = 1 To UBound(SplitArr) Step 1
l = 0
HTMLDocStr = ConvertToJsonClear(SplitArr(X))
Set Parsed = JsonConverter.ParseJson(HTMLDocStr)
For Each k In Parsed.Keys
l = l + 1
If X = 1 Then
Cells(1, l).Value = k
End If
Cells(X + 1, l).Value = Parsed(k)
'Debug.Print k & " = "; Parsed(k)
Next
'Stop
Next X
Stop
End Sub
Public Function ConvertToJsonClear(JSonStr As String) As String
JSonStr = JsonConverter.ConvertToJson(JSonStr)
JSonStr = Replace(JSonStr, "[", "")
JSonStr = Replace(JSonStr, "]", "")
JSonStr = Replace(JSonStr, "\", "")
If Left(JSonStr, 1) = Chr(34) Then
'Stop
JSonStr = Right(JSonStr, Len(JSonStr) - 1)
End If
If Left(JSonStr, 1) <> "{" Then
'Stop
JSonStr = "{" & JSonStr
End If
If Right(JSonStr, 3) = "},""" Then
'Stop
'Debug.Print Right(JSonStr, 3)
'Stop
JSonStr = Left(JSonStr, Len(JSonStr) - 2) & Chr(34)
End If
If Right(JSonStr, 1) = "," Then
'Stop
JSonStr = Left(JSonStr, Len(JSonStr) - 1)
End If
ConvertToJsonClear = JSonStr
'Debug.Print ConvertToJsonClear
End Function
I don't have my real data in front of me, but I tackled this a home with a homemade TestStr. The VBA-JSON parser linked in OP Comments by #TimWilliams worked great with a bit of string manipulation. I'll have to play around with real data and perhaps clean it up, but this works for now!
Public Sub JsonTest()
Dim TestStr As String, SplitArr() As String, k, I As Long
TestStr = "{""CC"":""TestA"",""DD"":""RESA"",""ZZ"":""RESAA""},{""CC"":""TestB"",""DD"":""RESB"",""ZZ"":""RESBB""}"
SplitArr = Split(TestStr, "{")
For I = 1 To UBound(SplitArr) Step 1
TestStr = JsonConverter.ConvertToJson("{" & SplitArr(I))
TestStr = Left(TestStr, Len(TestStr) - 1)
TestStr = Right(TestStr, Len(TestStr) - 1)
TestStr = Replace(TestStr, "\", "")
'Debug.Print TestStr
'Stop
Set Parsed = JsonConverter.ParseJson(TestStr)
For Each k In Parsed.Keys
Debug.Print k & " = " & Parsed(k)
'Stop
Next
Next
End Sub
Related
I paste data from elsewhere to a userform.
For example (the copied string)
Clinical: history of heart disease
Labs: elevated cholesterol on 8Aug
Meds: just started cholesterol medication
Supplements: none
Allergies: none
Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting
I want to paste the above string into textbox1.
The string should then be split into appropriate headings on textboxes 2 to 7 on the same userform.
In textbox 2, I want everything between "Clinical:" and "Labs:"
"history of heart disease" without the headings.
If “Labs:” is not present, I want everything between Clinical: and Meds (or next heading)
At this point, I think a loop to repeat this process but for the next items
(e.g. texbox 3 = everything between Labs: and Meds – or next heading; Textbox4 = everything between Meds: and Supplements) – or next heading; etc.
Private Sub CommandButton1_Click()
Dim strnames(1 To 6) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim check As Integer
str1 = TextBox1
x = 1
For box = 1 To 6
If InStr(TextBox1.Text, strnames(1)) > 0 Then
str2 = SuperMid(str1, strnames(x), strnames(x + 1))
TextBox2 = str2
End If
If InStr(TextBox1.Text, strnames(1)) = 0 Then
TextBox2 = "none"
End If
Next box
End sub
This is the code that I have been using (from wellsr.com) to capture the data between word1 and word2 of the array. The problem occurs when a word in the array is not present at which point it adds all of the text following the first word.
Public Function SuperMid(ByVal strMain As String, str1 As String, str2 As String,
Optional reverse As Boolean) As String
Dim i As Integer, j As Integer, temp As Variant
On Error GoTo errhandler:
If reverse = True Then
i = InStrRev(strMain, str1)
j = InStrRev(strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStrRev(strMain, str2, i)
If i = j Then 'try to search 2nd half of string for unique match
j = InStrRev(strMain, str2, i - 1)
End If
End If
If reverse = False Then
i = InStr(1, strMain, str1)
j = InStr(1, strMain, str2)
If Abs(j - i) < Len(str1) Then j = InStr(i + Len(str1), strMain, str2)
If i = j Then 'try to search 2nd half of string for unique match
j = InStr(i + 1, strMain, str2)
End If
End If
If i = 0 And j = 0 Then GoTo errhandler:
If j = 0 Then j = Len(strMain) + Len(str2) 'just to make it arbitrarily large
If i = 0 Then i = Len(strMain) + Len(str1) 'just to make it arbitrarily large
If i > j And j <> 0 Then 'swap order
temp = j
j = i
i = temp
temp = str2
str2 = str1
str1 = temp
End If
i = i + Len(str1)
SuperMid = Mid(strMain, i, j - i)
Exit Function
errhandler:
MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
End
End Function
Sometimes you need to add a little complication to make things easier. The code below may be of interest.
Option Explicit
' This code requires a reference to the Microsoft Scripting Runtime
Public Sub Test()
Dim myHistory As Scripting.Dictionary
Set myHistory = GetHistoryDictionary("Clinical: history of heart disease Labs: elevated cholesterol on 8AugMeds: just started cholesterol medication Supplements: none Allergies: none Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting)")
Debug.Print VBA.Join(myHistory.keys, vbCrLf)
Debug.Print VBA.Join(myHistory.Items, vbCrLf)
Debug.Print
If myHistory.Exists("Labs") Then
Debug.Print "The Lab report was: " & myHistory.Item("Labs")
End If
Debug.Print
If myHistory.Exists("Heamatology") Then
Debug.Print "The Heamatolofy report was: " & myHistory.Item("Heamatology")
Else
Debug.Print "The Heamtology report was: " & "Not Present"
End If
End Sub
Public Function GetHistoryDictionary(ByVal ipString As String) As Scripting.Dictionary
' Create an array of the labes in the input strings
Static myLabels As Variant
If VBA.IsEmpty(myLabels) Then
myLabels = Split("Clinical:,Labs:,Meds:,Supps:,Allergies:,Activity:,NFPE:", ",")
End If
' Add a character we can use as a separator with SPlit
Dim myLabel As Variant
For Each myLabel In myLabels
ipString = VBA.Replace(ipString, myLabel, "#" & myLabel)
Next
' remove characters until we have removed the first separator character
Do Until VBA.Left(ipString, 1) = "#"
ipString = VBA.Mid$(ipString, 2)
Loop
ipString = VBA.Mid$(ipString, 2)
'Get an array of Label/Message
Dim myItems As Variant
myItems = VBA.Split(ipString, "#")
'Split the label/message and put into a scripting.dictionary
Dim myHistory As Scripting.Dictionary
Set myHistory = New Scripting.Dictionary
Dim myItem As Variant
For Each myItem In myItems
Dim mySPlit As Variant
mySPlit = VBA.Split(myItem, ":")
myHistory.Add mySPlit(0), mySPlit(1)
Next
Set GetHistoryDictionary = myHistory
End Function
Building on your code:
First ensure you have Option Explicit at the top of all your modules as this will help pick out any simple errors.
In your UserForm you could have text boxes labeled TextBox1, TextBox2 etc. Then you could use this for the command button code:
Private Sub CommandButton1_Click()
Dim strnames(1 To 7) As String
strnames(1) = "Clinical: "
strnames(2) = "Labs: "
strnames(3) = "Meds: "
strnames(4) = "Supps: "
strnames(5) = "Allergies: "
strnames(6) = "Activity: "
strnames(7) = "NFPE: "
Dim str1 As String
str1 = TextBox1.Text
' It makes the code clearer if you are explicit about what you want
' from your text box - .Text (or .Value), even if VBA will
' give you its value if you don't specify it.
Dim str2 As String
Dim ctlControl As Control
Dim lngTextBoxNumber As Long
' You need to loop through all the controls on the form, and then
' determine which are the ones you want to alter. This assumes each
' textbox you are interested in is named in the form
' TextBox1, TextBox2 etc. To make code maintenance easier, I would
' probably put this kind of identification information on the
' controls' tag properties - that way if you rename the controls or
' you add a text box which is for something else, you won't break
' the code. You would then be reading this information off the
' .Tag property rather than .Name.
For Each ctlControl In Me.Controls
If Mid$(ctlControl.Name, 1, 7) = "TextBox" Then
lngTextBoxNumber = CLng(Mid$(ctlControl.Name, 8))
If lngTextBoxNumber > 1 And lngTextBoxNumber < UBound(strnames) Then
str2 = SuperMid(str1, strnames(lngTextBoxNumber), strnames(lngTextBoxNumber + 1))
If str2 = vbNullString Then
str2 = "none"
End If
ctlControl.Text = str2
End If
End If
Next ctlControl
End Sub
SuperMid seems to be quite an unforgiving function - as you have it, if it can't find the text before and after the text you are looking for, it will fail with an error: it might be better for it to return an empty string - otherwise your code will fail not all the strnames are present in your original string.
I altered the end of that function to look like this:
Exit Function
errhandler:
'MsgBox "Error extracting strings. Check your input" & vbNewLine & vbNewLine & "Aborting", , "Strings not found"
SuperMid = vbNullString
End Function
As it stands, your code would fail to pick up some of the information if items are left out, or had been entered in a different order: see freeflow's answer to avoid this.
I would skip the array because what you're really looking to do is to extract the phrase following the keyword. The example below shows how you can use a function to isolate the phrase.
Function ExtractByKeyword(ByVal source As String, _
ByVal keyword As String) As String
'--- extracts a phrase (substring) from the given source,
' beginning with the keyword and ending with the next
' (unknown) keyword.
' Keywords are delimited by a preceding space ' ' and
' followed by a colon ":" or EOL
Dim pos1 As Long
pos1 = InStr(1, source, keyword, vbTextCompare)
If pos1 = 0 Then
'--- the keyword was not found, so return a null string
ExtractByKeyword = vbNullString
Exit Function
End If
Dim phrase As String
'--- skip over the keyword and find the next keyword
' (i.e. look for the next colon)
Dim pos2 As Long
pos2 = InStr(pos1 + Len(keyword) + 1, source, ":", vbTextCompare)
If pos2 = 0 Then
'--- this is the last keyword and phrase in the source
phrase = Right$(source, Len(source) - pos1 - Len(keyword) - 1)
Else
'--- now work backwards from the second keyword to find the
' end of the phrase (which is the space just before the
' second keyword
Dim pos3 As Long
pos3 = InStrRev(source, " ", pos2, vbTextCompare)
Dim startsAt As Long
Dim phraseLen As Long
startsAt = pos1 + Len(keyword) + 2
phraseLen = pos3 - startsAt
phrase = Mid$(source, startsAt, phraseLen)
End If
ExtractByKeyword = phrase
End Function
I used the test routine below to check the extraction:
Option Explicit
Sub test()
Const medInfo As String = "Clinical: history of heart disease" & _
" Labs: elevated cholesterol on 8Aug" & _
" Meds: just started cholesterol medication" & _
" Supplements: none" & _
" Allergies: none" & _
" Activity: recently started going to YMCA 3x/wk (elliptical and some weight lifting"
Dim phrase As String
phrase = ExtractByKeyword(medInfo, "Labs")
If phrase <> vbNullString Then
Debug.Print " Labs -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Clinical")
If phrase <> vbNullString Then
Debug.Print " Clinical -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Activity")
If phrase <> vbNullString Then
Debug.Print " Activity -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Meds")
If phrase <> vbNullString Then
Debug.Print " Meds -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
phrase = ExtractByKeyword(medInfo, "Allergies")
If phrase <> vbNullString Then
Debug.Print "Allergies -> '" & phrase & "'"
Else
Debug.Print "Keyword not found!"
End If
End Sub
I am a novice programmer and I'm building a form via VBA for excel where the user will input employee's time sheet and their initials via 16 text box's in the form. The text boxes data are stored to a string array. The code is:
Dim initials(15) As String
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
...
initials(15) = TB_Initials_15
After using the find function and referencing some data from a one excel sheet, I use
ActiveCell.Offset(0, 2).Value = Join(initials, ".")
to output the following
"js.rs.............." to the active cell in a different excel sheet, (I only entered 2 of the 16 input boxes, hence there's two initials. JS.RS
The trailing .............. is what I want to remove. this will be imported into a Database later via the excel sheet.
How can I remove the xtras ".........'s at the end of the string? I have tried the "Trim()" function, but that does not work in my case. Everything i've tried online does not seem to work either or is referencing items from a work book, not a text box.
Any help is appreciated.
The entire code is below:
Option Explicit
'Variable declaration
Dim startTime(15), endTime(15), ST_Finish_Date As Date
Dim totalmin(15), Total_min, Total_Cost, Rate(15), Line_cost(15), Cost_Per_Part As String
Dim initials(15) As String
Dim i, ii As Integer
Dim Found_ini(15) As Range
Dim Found As Range 'returned value from find
Dim TBtraveller_value As String 'text box traveller value
Dim Found2 As Range 'store part code range
Dim TBDESC As Range ' Returned value from 2nd search
Dim BL_Find_Check As Boolean
Private Sub CB_Write_Click()
create_csv
End Sub
Private Sub Close_Form_Click()
Unload Traveller_Entry
End Sub
'still need to make this for every start / stop time text box.
Private Sub TB_Time_Start_1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim myvar As String
If Not Me.TB_Time_Start_1 Like "??:??" Then
MsgBox "Please use format 'HH:MM'"
Cancel = True
Exit Sub
End If
myvar = Format(Me.TB_Time_Start_1, "hh:mm")
Me.TB_Time_Start_1 = myvar
End Sub
Public Sub travellerNUM_TextBox_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Workbooks("Traveller entryxlsm.xlsm").Activate
TBtraveller_value = travellerNUM_TextBox.Value
If TBtraveller_value = "" Then
MsgBox ("Enter a Shop Traveller Number!")
Exit Sub
Else
TBtraveller_value = travellerNUM_TextBox.Value
Set Found = Sheets("woss").Range("A:A").Find(what:=TBtraveller_value, lookat:=xlWhole)
If Found Is Nothing Then
MsgBox (TBtraveller_value & " Not Found!")
Exit Sub
Else
Part_Code_BOX.Value = Found.Offset(0, 1) 'enters the info into the Part Code Box.
Set Found2 = Found.Offset(0, 1)
End If
If Part_Code_BOX = "" Then
MsgBox ("Traveller number " & TBtraveller_value & " has no part code associated with it." & vbCrLf & "Check Work Order Spread Sheet is FULLY Complete.")
BL_Find_Check = True
Exit Sub
End If
Set TBDESC = Sheets("ProductList").Range("B:B").Find(what:=Found2, lookat:=xlPart)
If TBDESC Is Nothing Then
MsgBox (" Dscription Not Found!")
Else
Desc_Box = TBDESC.Offset(0, 1) 'enters the description into the description Box.
FinishDate_Box = Found.Offset(0, 8) 'enters the finish date into the finish date Box.
Employee = Found.Offset(0, 2) 'enters the Employee name into the employee name Box.
End If
End If
End Sub
Public Sub CB_POST_Click()
On Error Resume Next
startTime(0) = TB_Time_Start_1.Value
startTime(1) = TB_Time_Start_2.Value
startTime(2) = TB_Time_Start_3.Value
startTime(3) = TB_Time_Start_4.Value
startTime(4) = TB_Time_Start_5.Value
startTime(5) = TB_Time_Start_6.Value
startTime(6) = TB_Time_Start_7.Value
startTime(7) = TB_Time_Start_8.Value
startTime(8) = TB_Time_Start_9.Value
startTime(9) = TB_Time_Start_10.Value
startTime(10) = TB_Time_Start_11.Value
startTime(11) = TB_Time_Start_12.Value
startTime(12) = TB_Time_Start_13.Value
startTime(13) = TB_Time_Start_14.Value
startTime(14) = TB_Time_Start_15.Value
startTime(15) = TB_Time_Start_16.Value
endTime(0) = TB_Time_Stop_1.Value
endTime(1) = TB_Time_Stop_2.Value
endTime(2) = TB_Time_Stop_3.Value
endTime(3) = TB_Time_Stop_4.Value
endTime(4) = TB_Time_Stop_5.Value
endTime(5) = TB_Time_Stop_6.Value
endTime(6) = TB_Time_Stop_7.Value
endTime(7) = TB_Time_Stop_8.Value
endTime(8) = TB_Time_Stop_9.Value
endTime(9) = TB_Time_Stop_10.Value
endTime(10) = TB_Time_Stop_11.Value
endTime(11) = TB_Time_Stop_12.Value
endTime(12) = TB_Time_Stop_13.Value
endTime(13) = TB_Time_Stop_14.Value
endTime(14) = TB_Time_Stop_15.Value
endTime(15) = TB_Time_Stop_16.Value
initials(0) = TB_Initials_1
initials(1) = TB_Initials_2
initials(2) = TB_Initials_3
initials(3) = TB_Initials_4
initials(4) = TB_Initials_5
initials(5) = TB_Initials_6
initials(6) = TB_Initials_7
initials(7) = TB_Initials_8
initials(8) = TB_Initials_9
initials(9) = TB_Initials_10
initials(10) = TB_Initials_11
initials(11) = TB_Initials_12
initials(12) = TB_Initials_13
initials(13) = TB_Initials_14
initials(14) = TB_Initials_15
initials(15) = TB_Initials_16
For i = LBound(initials) To UBound(initials)
Set Found_ini(i) = Sheets("rate").Range("B:B").Find(what:=initials(i), lookat:=xlWhole)
Rate(i) = Found_ini(i).Offset(0, 1) 'finds rate for given initials
totalmin(i) = DateDiff("N", startTime(i), endTime(i))
If Found_ini(i) Is Nothing Then
MsgBox (initials(i) & " Not Found! Update Employee Database.")
Exit Sub
'If IsEmpty(Found_ini(i)) = False And IsEmpty(startTime(i)) = True And IsEmpty(endTime(i)) = True Then
'MsgBox "Enter Some Initials, None Found"
Exit Sub
End If
Next
For ii = LBound(totalmin) To UBound(totalmin)
Line_cost(ii) = totalmin(ii) / 60 * Rate(ii)
Next
Total_min = Application.WorksheetFunction.Sum(totalmin)
Total_Cost = Application.WorksheetFunction.Sum(Line_cost)
Cost_Per_Part = Total_Cost / TextBOX_QTYBUILT
If Total_min = 0 Then
MsgBox (" Enter Some Time!")
ElseIf Total_min < 0 Then
MsgBox ("Time is NEGATIVE. Check Entered Times.")
End If
If BL_Find_Check = False Then
MsgBox "The number of minutes between two Times : " & Total_min & vbNewLine & "total cost: " & Total_Cost _
& vbNewLine & "cost Per Part " & Cost_Per_Part, vbInformation, "Minutes Between Two Times"
Sheets("test").Select
Range("A1048576").Select
ActiveCell.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 0).Value = FinishDate_Box 'Traveller finish Date
ActiveCell.Offset(0, 1).Value = TBtraveller_value 'Traveller Number
ActiveCell.Offset(0, 2).Value = Join(initials, ".") 'Traveller Employee Given to
ActiveCell.Offset(0, 3).Value = Part_Code_BOX.Value ' part number
ActiveCell.Offset(0, 4).Value = Total_Cost ' traveller total cost
ActiveCell.Offset(0, 5).Value = Cost_Per_Part 'Traveller cost per part
End If
End Sub
Sub create_csv()
Dim FileName As String
Dim PathName As String
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("test")
FileName = "CSV_Output_R1.csv"
PathName = Application.ActiveWorkbook.Path
ws.Copy
ActiveWorkbook.SaveAs FileName:=PathName & "\" & FileName, _
FileFormat:=xlCSV, CreateBackup:=False
End Sub
Thank you,
You can use WorksheetFunction.TextJoin() in Excel2019+ in one string:
ActiveCell.Offset(0, 2).Value = WorksheetFunction.TextJoin(".", True, initials)
A small example for comparison:
Sub test1()
Dim arr(1 To 15)
For i = 1 To 15
arr(i) = IIf(Rnd() > 0.7, "TXT", "")
Next
Debug.Print "With Join(): " & Join(arr, ".")
Debug.Print "With TextJoin(): " & WorksheetFunction.TextJoin(".", True, arr)
End Sub
Output
With Join(): ..TXT........TXT..TXT..
With TextJoin(): TXT.TXT.TXT
Here is a function that I just made to trim empty elements off the end of your array:
Function TrimArray(ByRef StringArray() As String) As String()
'This function removes trailing empty elements from arrays
'Searching from the last element backwards until a non-blank is found
Dim i As Long
For i = UBound(StringArray) To LBound(StringArray) Step -1
If StringArray(i) <> "" Then Exit For
Next i
If i < LBound(StringArray) Then i = LBound(StringArray)
'Creating an array with the correct size to hold the non-blank elements
Dim OutArr() As String
OutArr = StringArray
ReDim Preserve OutArr(LBound(StringArray) To i)
TrimArray = OutArr
End Function
You would use it like so:
Dim Output() As String
Output = TrimArray(initials)
MsgBox Join(Output, ".") & "."
You could build it like this instead of using Join():
ActiveCell.Offset(0, 2).Value = initials(0)
For Counter = 1 To 15
If initials(Counter) <> "" Then
ActiveCell.Offset(0, 2).Value = ActiveCell.Offset(0, 2).Value + "." + initials(Counter)
End If
Next Counter
I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter
I have some VBA I am wanting to use to update and add data to a table on an SQL server. I have been muddling through with limited knowledge of this functionality within VBA all day, searching various sites and not really getting any answers to make things click into place and not getting any response when posting it elsewhere. Hopefully I can get this solved here.
So, I have the following code that I have cobbled together:
Sub connectsqlserver()
Dim conn As ADODB.Connection
Dim recset As ADODB.Recordset
Set conn = New ADODB.Connection
Set recset = New ADODB.Recordset
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim msgstrng As String
Dim newstring As String
If conn.State <> 0 Then
conn.Close
End If
With conn
.ConnectionString = "Driver={SQL Server};server=sage500;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.ConnectionTimeout = 5
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 1 To Sheets("Changes").Range("A1").Value
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
'Do something
Next i
Sheets("Changes").Rows("3:" & i + 2).Delete xlUp
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 1 To Sheets("New").Range("A1").Value
newstring = ""
For k = 1 To 38
If k = 38 Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
Debug.Print (newstring)
With recset
.AddNew (newstring)
.Update
End With
Next j
Sheets("New").Rows("3:" & j + 2).Delete xlUp
Else
j = 0
End If
recset.Close
conn.Close
If i = 0 And j = 0 Then
msgstring = "No Changes/New Data to add"
Else
If i = 0 And j <> 0 Then
msgstring = "No Changes and " & j & " New Customers added"
Else
If i <> 0 And j = 0 Then
msgstring = i & " Changes and no New Customers added"
Else
msgstring = i & " Changes and " & j & " New Customers added"
End If
End If
End If
End Sub
Part 1: This currently throws out an error at "With recset.AddNew..." (3001) saying that arguments are of the wrong type. The table it is going to is formatted as nvarchar(255) and all the data is formatted as text in the various fields so I am not entirely sure whats happening there.
Part 1 code:
If lastrow <> 0 Then
For j = 1 To lastrow
For k = 1 To lastfield
If k = lastfield Then
newstring = newstring & "'" & Cells(j + 2, k).Value & "'"
Else
newstring = newstring & "'" & Cells(j + 2, k).Value & "', "
newstring = Format(newstring, "")
End If
Next k
With recset
.AddNew (newstring)
.Update
End With
Next j
End If
Part 2: As my knowledge of VBA for ADODB connections is awful at best, I cannot figure out how to continue once I have found the row I require, hence the "'Do something" line. What I need this to do is find the record matched from column B in the "Changes" excel table and then edit that row in the SQL table to match it. I can't figure out how to do this though.
Part 2 code:
If lastrow <> 0 Then
For i = 1 To lastrow
recset.Find "Col2 = " & Sheets("Changes").Cells(2, i + 2) 'find the value in B from B3 onwards
' Do something
Next i
End If
EDIT: I have this from the debug.print which may help some people visualise this a bit more:
"23/07/13","TEST123","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test","Test"
This is for a full line (so therefore the Field List should not be required as this is data for every column in the correct order).
From what you posted, I believe you've been trying to concatenate all the values into a string separated by ','. (correct me if I'm wrong)
This answer is only useful if you wanted to append new data, if you want to find a specific record in the database and update it then its a completely different story.
The "Add New" method takes in two arguments.
The list of fields in array format
The list of values in array format
Unless you have only one field or one value to add you should put them into array before using the "Add New" method.
A possible way of constructing the arrays:
For i = 0 to count_of_fields
aryFields(i) = field_value
Next
For i = 0 to count_of_values
aryValues(i) = value
Next
recset.AddNew aryFields,aryValues
recset.Update
Let me know if that helps!
Will post this now actually instead of Monday or else I may forget.
Ended up being the neatest solution as working with arrays in this case seemed to fail a lot and they are a lot harder to debug. This at least made it a lot simpler.
Also, was good finding out that once you have found the row (my part 2 question), that it is in fact the same process as with .addnew (which was what I was not sure of)
With conn
.ConnectionString = "Driver={SQL Server};server=sage;Database=CS3Live;Uid=sa;Pwd=pass; ReadOnly=False;"""
.Open
End With
recset.Open Source:="custinfosheetdata", ActiveConnection:=conn, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If Sheets("Changes").Range("A1").Value <> 0 Then
For i = 3 To LastRow
With recset
.Find "Col2 = " & "'" & Sheets("Changes").Range("B" & i) & "'"
For k = 1 To 38
strField = Sheets("Changes").Cells(2, k).Value
varValue = Sheets("Changes").Cells(i, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next i
Else
i = 0
End If
If Sheets("New").Range("A1").Value <> 0 Then
For j = 3 To LastRow
With recset
.AddNew
For k = 1 To 38
strField = Sheets("New").Cells(2, k).Value
varValue = Sheets("New").Cells(j, k).Value
.Fields(strField).Value = varValue
Next k
.Update
End With
Next j
Else
j = 0
End If
... etc
So anyway, thanks to all that tried helping on here. I still cannot understand why arrays were not working though.
I have saved a really big QueryString into a MS SQL column the string looks something like this:
&s1=Toledo,OH&s2=Chicago,IL&s3=Madison,WI.....and so on...
I would like to be able to do/have something like this in ASP-Classic:
Dim s1,s2,s3,s4....and son on...
s1="Toledo,OH"
s2="Chicago,IL"
s3="Madison,WI"
.....and son on.....
I would like to be able to call them like I would a QueryString for example a QueryString call would be Request.QueryString("s1") or I can use Do and loop all of the Request.QueryString("s" & i) until the query ="" then I would Exit the Do.
But how would I make all of this happen if I saved it the query.string into a MS DB Column?
Please help,
Thank you...
I keep getting this error: Variable is undefined: 's1', what am I doing wrong here ?
Function qq(s)
qq = """" & s & """"
End Function ' qq
Dim sInp : sInp = objRSConnSAVE("QSTRING")
Dim dicData : Set dicData = Server.CreateObject("Scripting.Dictionary")
Dim oRE : Set oRE = New RegExp
oRE.Global = True
oRE.Pattern = "&([^=]+)=([^&]*)"
Dim oMTS : Set oMTS = oRE.Execute(sInp)
Dim oMT
For Each oMT In oMTS
dicData(oMT.SubMatches(0)) = oMT.SubMatches(1)
Next
Dim sKey, sValue
For Each sKey In dicData.Keys
sValue = dicData(sKey)
'''// Response.write qq(sKey) & "=>" & qq(sValue)
Next
Response.write "TEST" & s1
'// I even tried Response.write "TEST" & s(1) same error, how do I call it ?
Use a RegExp (instead of Split) and a dictionary (instead of a bunch of scalar variables):
Dim sInp : sInp = "&s1=Toledo,OH&s2=Chicago,IL&s3=Madison,WI"
Dim dicData : Set dicData = CreateObject("Scripting.Dictionary")
Dim oRE : Set oRE = New RegExp
oRE.Global = True
oRE.Pattern = "&([^=]+)=([^&]*)"
Dim oMTS : Set oMTS = oRE.Execute(sInp)
Dim oMT
For Each oMT In oMTS
dicData(oMT.SubMatches(0)) = oMT.SubMatches(1)
Next
Dim sKey, sValue
For Each sKey In dicData.Keys
sValue = dicData(sKey)
WScript.Echo qq(sKey), "=>", qq(sValue)
Next
output:
"s1" => "Toledo,OH"
"s2" => "Chicago,IL"
"s3" => "Madison,WI"
UPDATE:
qq() is a function to double quote a string:
Function qq(s)
qq = """" & s & """"
End Function ' qq
UPDATE II:
Use dicData("s2") to get Chicago,IL
Why declare s1, s2, etc.?
Create a variable to be used as an array, and use the Split function on the string by the ampersand (&), and then when you need to reference an individual row, split it again on the equal sign (=).
For example:
arMyArray = Split(YourQueryString, "&")
for i = 0 to uBound(arMyArray)
key = Split(arMyArray(i), "=")(0)
cityAndState = Split(arMyArray(i), "=")(1)
next