I'm trying to split certain values in Excel using VB and then creating an XML document using the getelementsbytagname to create the structure of the file. I have it splitting at the semicolon for the Creator, Subject, and Contributors fields in Excel. This does work but i would like to have separate tags for each entry that was split. Currently, all the entries are in one tag separated by semicolon. I'm able to split the values correctly but I get a mismatch error 13 on the doc.getElementsByTagName("Creator")(0).appendChild doc.createTextNode(sCreator), which is the first field that I try to split. Is there a way to create a loop in the below code so it would go through the code and add separate XML tags for each field that I'm splitting (Creator, Subject, Contributors)?
Sub XLStoXML()
sTemplateXML = _
"<?xml version='1.0' encoding='UTF-8'?>" + vbNewLine + _
"<odu xmlns='https://dc.lib.odu.edu'>" + vbNewLine + _
" <Identifier>" + vbNewLine + _
" </Identifier>" + vbNewLine + _
" <Title>" + vbNewLine + _
" </Title>" + vbNewLine + " <Creator>" + vbNewLine + " </Creator>" + vbNewLine + " <Subject>" + vbNewLine + " </Subject>" + " <Description>" + vbNewLine + " </Description>" + vbNewLine + " <Contributors>" + vbNewLine + " </Contributors>" + vbNewLine + _
" <Publisher>" + vbNewLine + " </Publisher>" + vbNewLine + " <Date>" + vbNewLine + " </Date>" + vbNewLine + " <Coverage>" + vbNewLine + " </Coverage>" + vbNewLine + _
" <Language>" + vbNewLine + " </Language>" + vbNewLine + " <Languagecode>" + vbNewLine + " </Languagecode>" + vbNewLine + " <Source>" + vbNewLine + " </Source>" + vbNewLine + " <Findingaid>" + vbNewLine + " </Findingaid>" + vbNewLine + _
" <RightsStatement>" + vbNewLine + " </RightsStatement>" + vbNewLine + " <Rightsholder>" + vbNewLine + " </Rightsholder>" + vbNewLine + " <Disclaimer>" + vbNewLine + " </Disclaimer>" + vbNewLine + " <Contributinginstitution>" + vbNewLine + " </Contributinginstitution>" + vbNewLine + _
" <Electronicpublisher>" + vbNewLine + " </Electronicpublisher>" + vbNewLine + " <Format>" + vbNewLine + " </Format>" + vbNewLine + " <Mediaformat>" + vbNewLine + " </Mediaformat>" + vbNewLine + " <Resourcetype>" + vbNewLine + " </Resourcetype>" + vbNewLine + " <Datedigital>" + vbNewLine + " </Datedigital>" + vbNewLine + _
" <Filesize>" + vbNewLine + " </Filesize>" + vbNewLine + " <Collection>" + vbNewLine + " </Collection>" + vbNewLine + " <Digitizedby>" + vbNewLine + " </Digitizedby>" + vbNewLine + " <Digitalcollection>" + vbNewLine + " </Digitalcollection>" + vbNewLine + " <Digitalrepository>" + vbNewLine + " </Digitalrepository>" + vbNewLine + _
" <Transcript>" + vbNewLine + " </Transcript>" + vbNewLine + " <Filename>" + vbNewLine + " </Filename>" + vbNewLine + _
"</odu>" + vbNewLine
Set doc = CreateObject("MSXML2.DOMDocument")
doc.async = False
doc.validateOnParse = False
doc.resolveExternals = False
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 2 To lLastRow
sFile = .Cells(lRow, 1).Value
sIdentifier = .Cells(lRow, 2).Value
sTitle = .Cells(lRow, 3).Value
Dim sCreator() As String
sCreator = Split(.Cells(lRow, 4), ";")
Dim sSubject() As String
sSubject = Split(.Cells(lRow, 5).Value, ";")
sDescription = .Cells(lRow, 6).Value
Dim sContributors() As String
sContributors = Split(.Cells(lRow, 7).Value, ";")
sPublisher = .Cells(lRow, 8).Value
sDate = .Cells(lRow, 9).Value
sCoverage = .Cells(lRow, 10).Value
sLanguage = .Cells(lRow, 11).Value
sLanguagecode = .Cells(lRow, 12).Value
sSource = .Cells(lRow, 13).Value
sFindingaid = .Cells(lRow, 14).Value
sRightsStatement = .Cells(lRow, 15).Value
sRightsholder = .Cells(lRow, 16).Value
sDisclaimer = .Cells(lRow, 17).Value
sContributinginstitution = .Cells(lRow, 18).Value
sElectronicpublisher = .Cells(lRow, 19).Value
sFormat = .Cells(lRow, 20).Value
sMediaformat = .Cells(lRow, 21).Value
sResourcetype = .Cells(lRow, 22).Value
sDatedigital = .Cells(lRow, 23).Value
sFilesize = .Cells(lRow, 24).Value
sCollection = .Cells(lRow, 25).Value
sDigitizedby = .Cells(lRow, 26).Value
sDigitalcollection = .Cells(lRow, 27).Value
sDigitalrepository = .Cells(lRow, 28).Value
sTranscript = .Cells(lRow, 29).Value
sFilename = .Cells(lRow, 30).Value
doc.LoadXML sTemplateXML
doc.getElementsByTagName("Identifier")(0).appendChild doc.createTextNode(sIdentifier)
doc.getElementsByTagName("Title")(0).appendChild doc.createTextNode(sTitle)
doc.getElementsByTagName("Creator")(0).appendChild doc.createTextNode(sCreator)
doc.getElementsByTagName("Subject")(0).appendChild doc.createTextNode(sSubject)
doc.getElementsByTagName("Description")(0).appendChild doc.createTextNode(sDescription)
doc.getElementsByTagName("Contributors")(0).appendChild doc.createTextNode(sContributors)
doc.getElementsByTagName("Publisher")(0).appendChild doc.createTextNode(sPublisher)
doc.getElementsByTagName("Date")(0).appendChild doc.createTextNode(sDate)
doc.getElementsByTagName("Coverage")(0).appendChild doc.createTextNode(sCoverage)
doc.getElementsByTagName("Language")(0).appendChild doc.createTextNode(sLanguage)
doc.getElementsByTagName("Languagecode")(0).appendChild doc.createTextNode(sLanguagecode)
doc.getElementsByTagName("Source")(0).appendChild doc.createTextNode(sSource)
doc.getElementsByTagName("Findingaid")(0).appendChild doc.createTextNode(sFindingaid)
doc.getElementsByTagName("RightsStatement")(0).appendChild doc.createTextNode(sRights)
doc.getElementsByTagName("Rightsholder")(0).appendChild doc.createTextNode(sRightsholder)
doc.getElementsByTagName("Disclaimer")(0).appendChild doc.createTextNode(sDisclaimer)
doc.getElementsByTagName("Contributinginstitution")(0).appendChild doc.createTextNode(sContributinginstitution)
doc.getElementsByTagName("Electronicpublisher")(0).appendChild doc.createTextNode(sElectronicpublisher)
doc.getElementsByTagName("Format")(0).appendChild doc.createTextNode(sFormat)
doc.getElementsByTagName("Mediaformat")(0).appendChild doc.createTextNode(sMediaformat)
doc.getElementsByTagName("Resourcetype")(0).appendChild doc.createTextNode(sResourcetype)
doc.getElementsByTagName("Datedigital")(0).appendChild doc.createTextNode(sDatedigital)
doc.getElementsByTagName("Filesize")(0).appendChild doc.createTextNode(sFilesize)
doc.getElementsByTagName("Collection")(0).appendChild doc.createTextNode(sCollection)
doc.getElementsByTagName("Digitizedby")(0).appendChild doc.createTextNode(sDigitizedby)
doc.getElementsByTagName("Digitalcollection")(0).appendChild doc.createTextNode(sDigitalcollection)
doc.getElementsByTagName("Digitalrepository")(0).appendChild doc.createTextNode(sDigitalrepository)
doc.getElementsByTagName("Transcript")(0).appendChild doc.createTextNode(sTranscript)
doc.getElementsByTagName("Filename")(0).appendChild doc.createTextNode(sFilename)
doc.Save sFile
Next
End With
End Sub
Since is was a mismatch error 13, I tried changing those three tags to a string type but that didn't work
Related
I continuously need to evaluate sets of raw data (1-1000 rows, 3 columns) in 5-15 sheets every time.
For two of the columns I have written a code that helps me take the average of every 5th value (every 5th row) adjusted to the number of rows by a reoccurring text value at the bottom. I want to calculate the residual of every raw value, in steps of 5, to the average within that range.
This is a screen shot out of the data set and the average calculation
It would be easy to calculate the residual for every row if the average was printed out on every row, and then do the residual calculation, but I can't figure out how and that is what I need help with.
Here is my code so far
Dim i As Integer
rownum = Range(ToCellB.Address).Row 'This is a reference to cell at the bottom at which the average function should end
For i = 23 To rownum Step 5
ActiveSheet.Range("L" & i).Value = _
(ActiveSheet.Range("B" & i).Value + _
ActiveSheet.Range("B" & i + 1).Value + _
ActiveSheet.Range("B" & i + 2).Value + _
ActiveSheet.Range("B" & i + 3).Value + _
ActiveSheet.Range("B" & i + 4).Value) / 5
ActiveSheet.Range("M" & i).Value = _
(ActiveSheet.Range("G" & i).Value + _
ActiveSheet.Range("G" & i + 1).Value + _
ActiveSheet.Range("G" & i + 2).Value + _
ActiveSheet.Range("G" & i + 3).Value + _
ActiveSheet.Range("G" & i + 4).Value) / 5
Next i
The Range object can contain more than one cell, and if this is the case, assigning a value to it assigns the value to the whole range.
Use
Dim i As Integer
rownum = Range(ToCellB.Address).Row
For i = 23 To rownum Step 5
ActiveSheet.Range("L" & i & ":L" & i + 4).Value = _
(ActiveSheet.Range("B" & i).Value + _
ActiveSheet.Range("B" & i + 1).Value + _
ActiveSheet.Range("B" & i + 2).Value + _
ActiveSheet.Range("B" & i + 3).Value + _
ActiveSheet.Range("B" & i + 4).Value) / 5
ActiveSheet.Range("M" & i & ":M" & i + 4).Value = _
(ActiveSheet.Range("G" & i).Value + _
ActiveSheet.Range("G" & i + 1).Value + _
ActiveSheet.Range("G" & i + 2).Value + _
ActiveSheet.Range("G" & i + 3).Value + _
ActiveSheet.Range("G" & i + 4).Value) / 5
Next i
instead.
This create a range Range("L23:L27") for example, and then the entire range is populated with the local average.
Also, a call to the value property is implicit in VBA:
The default member of Range forwards calls without parameters to Value. Thus, someRange = someOtherRange is equivalent to someRange.Value = someOtherRange.Value.
and can be dropped.
And ToCellB is already a range, and so you can just write:
Dim i As Integer
rownum = ToCellB.Row
For i = 23 To rownum Step 5
ActiveSheet.Range("L" & i & ":L" & i + 4) = _
(ActiveSheet.Range("B" & i) + _
ActiveSheet.Range("B" & i + 1) + _
ActiveSheet.Range("B" & i + 2) + _
ActiveSheet.Range("B" & i + 3) + _
ActiveSheet.Range("B" & i + 4)) / 5
ActiveSheet.Range("M" & i & ":M" & i + 4) = _
(ActiveSheet.Range("G" & i) + _
ActiveSheet.Range("G" & i + 1) + _
ActiveSheet.Range("G" & i + 2) + _
ActiveSheet.Range("G" & i + 3) + _
ActiveSheet.Range("G" & i + 4)) / 5
Next i
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.range.value
Im trying to send json object in Outlook using vba. Here is my code:
Dim Msg As Outlook.MeetingItem
Set Msg = Item
Set recips = Msg.Recipients
Dim regEx As New RegExp
regEx.Pattern = "^\w+\s\w+,\sI351$"
Dim URL As String
URL = "https://webhook.site/55759d1a-7892-4c20-8d15-3b8b7f1bf3b3"
For Each recip In recips
If regEx.Test(recip.AddressEntry) And recip.AddressEntry <> "Application Management Linux1, I351" Then
Dim convertedJson As Object
Set convertedJson = JsonConverter.ParseJson("{""fields"": 123}")
Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0")
xhr.Open "POST", URL, False
xhr.setRequestHeader "Content-Type", "application/json"
xhr.Send (convertedJson)
End If
Next
If I send just plane text it works well but i can't send convertedJson. Is it possible to send an object?
UPDATE
I can't even do Debug.Print convertedJson
I was tormented by these libraries in the end I did a very terrible thing
Dim flds, prt, id, smry, descrp, issu, name, lfbrkt, rtbrkt, cma, dbdots, jsTest, issuName As String
flds = "'fields'"
prt = "'project'"
id = "'id'"
smry = "'summary'"
descrp = "'description'"
issu = "'issuetype'"
issuName = "'Improvement'"
name = "'name'"
lfbrkt = "{"
rtbrkt = "}"
cma = ","
dbdots = ":"
jsTest = lfbrkt + flds + dbdots + " " + lfbrkt + vbCrLf + vbTab + prt + dbdots + " " + lfbrkt + vbCrLf + vbTab + vbTab + id + dbdots + " " + "30611" + vbCrLf + vbTab + rtbrkt + cma + vbCrLf + vbTab + smry + dbdots + " " + "'" + CStr(Msg.Subject) + "'" + cma + vbCrLf + vbTab + descrp + dbdots + " " + "'" + CStr(Msg.Body) + "'" + cma + vbCrLf + vbTab + issu + dbdots + " " + lfbrkt + vbCrLf + vbTab + vbTab + name + dbdots + " " + issuName + vbCrLf + vbTab + rtbrkt + vbCrLf + rtbrkt + rtbrkt
And I got this
Dim a As Long
a = range("A617:A737").Copy
s = range("A739:A" & EndLine + 2).PasteSpecial
Dim FinalLine As Long
FinalLine = Cells(Rows.Count, "A").End(xlUp).Row
range("B739").AutoFill Destination:=range("B739:B" & FinalLine - 2)
Cells(FinalLine + 10, 2).Formula = "= 5"
Cells("B" & FinalLine + 3).FormulaArray = _
"= Min(If(B739:B" & FinalLine - 2 = FinalLine + 10 & " , A$739:A$" & EndLine + 2))"
The error is highlighting the comma after the 10.
Cells(FinalLine + 3, "B").FormulaArray = _
"= MIN(IF(B739:B" & (FinalLine - 2) & "=5 , A$739:A$" & (EndLine + 2) & ", """"))"
corrected code...
Cells( FinalLine + 3,"B").FormulaArray = "= Min(If(B739:B" & FinalLine - 2 = FinalLine + 10 & " , A$739:A$" & EndLine + 2 & ", """"))"
I'm trying to make excel create XML files using VBA (that my first time), so I managed to create a code but I keep getting the message that there are too many line continuations
Here is my code
Sub testXLStoXML()
sTemplateXML = _
"<?xml version='1.0'?>" + vbNewLine + _
"<offers>" + vbNewLine + _
" <offer>" + vbNewLine + _
" <offer_identifier>" + vbNewLine + _
" </offer_identifier>" + vbNewLine + _
" <offer_title>" + vbNewLine + _
" </offer_title>" + vbNewLine + _
" <offer_description>" + vbNewLine + _
" </offer_description>" + vbNewLine + _
" <offer_featured_image>" + vbNewLine + _
" </offer_featured_image>" + vbNewLine + _
" <offer_cat>" + vbNewLine + _
" </offer_cat>" + vbNewLine + _
" <offer_location>" + vbNewLine + _
" </offer_location>" + vbNewLine + _
" <offer_tags>" + vbNewLine + _
" </offer_tags>" + vbNewLine + _
" <offer_type>" + vbNewLine + _
" </offer_type>" + vbNewLine + _
" <offer_start>" + vbNewLine + _
" </offer_start>" + vbNewLine + _
" <offer_expire>" + vbNewLine + _
" </offer_expire>" + vbNewLine + _
" <offer_store>" + vbNewLine + _
" </offer_store>" + vbNewLine + _
" <!-- store -->" + vbNewLine + _
" <store_title>" + vbNewLine + _
" </store_title>" + vbNewLine + _
" <store_letter>" + vbNewLine + _
" </store_letter>" + vbNewLine + _
" <store_description>" + vbNewLine + _
" </store_description>" + vbNewLine + _
" <store_logo>" + vbNewLine + _
" </store_logo>" + vbNewLine + _
" <store_link>" + vbNewLine + _
" </store_link>" + vbNewLine + _
" <store_facebook>" + vbNewLine + _
" </store_facebook>" + vbNewLine + _
" <store_twitter>" + vbNewLine + _
" </store_twitter>" + vbNewLine + _
" <store_google>" + vbNewLine + _
" </store_google>" + vbNewLine + _
" <!-- store -->" + vbNewLine + _
" <!-- DEAL RELATED -->" + vbNewLine + _
" <deal_items>" + vbNewLine + _
" </deal_items>" + vbNewLine + _
" <deal_item_vouchers>" + vbNewLine + _
" </deal_item_vouchers>" + vbNewLine + _
" <deal_price>" + vbNewLine + _
" </deal_price>" + vbNewLine + _
" <deal_sale_price>" + vbNewLine + _
" </deal_sale_price>" + vbNewLine + _
" <deal_discount>" + vbNewLine + _
" </deal_discount>" + vbNewLine + _
" <deal_voucher_expire>" + vbNewLine + _
" </deal_voucher_expire>" + vbNewLine + _
" <deal_in_short>" + vbNewLine + _
" </deal_in_short>" + vbNewLine + _
" <deal_type>" + vbNewLine + _
" </deal_type>" + vbNewLine + _
" <deal_link>" + vbNewLine + _
" </deal_link>" + vbNewLine + _
" </offer>" + vbNewLine + _
"</offers>" + vbNewLine +
Is there a way to bypass the limit or make this work?
Per Microsoft, "There is a limit to the number of lines you can join with line-continuation characters. This error has the following cause and solution:
Your code has more than 25 physical lines lines joined with line-continuation characters, or more than 24 consecutive line-continuation characters in a single line. Make some of the constituent lines physically longer to reduce the number of line-continuation characters needed, or break the construct into more than one statement."
The line continuations are merely for ease of reading the code and are necessary to have after each tag the way you have it now
code is building the email but it is only displaying one row when there is six. I got it correct on the text file but I need it to do the same in the email message. I think I got the for next statement in the wrong location. Here is the example of the code that I am having problem with. I do not know how to place the for next statement without interrupting the vbLine
For Each p In query
If p.Contract_No IsNot Nothing Then
ContractNo = p.Contract_No
Else
ContractNo = " "
End If
If p.Vendor_Name IsNot Nothing Then
VenderName = p.Vendor_Name
Else
VenderName = " "
End If
If p.Termination_Date IsNot Nothing Then
TerminationDate = p.Termination_Date
' ReportDateStr = ReportDate.ToString
TerminationDateStr = String.Format("{0:MM/dd/yyyy}", TerminationDate)
Else
TerminationDateStr = " "
End If
If p.Dept_Name IsNot Nothing Then
DeptName = p.Dept_Name
Else
DeptName = " "
End If
If p.Renewal_Option_Desc IsNot Nothing Then
RenewalOption = p.Renewal_Option_Desc
Else
RenewalOption = " "
End If
If p.Contract_Desc IsNot Nothing Then
ContractDesc = p.Contract_Desc
Else
ContractDesc = " "
End If
If p.Contact_Email IsNot Nothing Then
ContactEmail = p.Contact_Email
Else
ContactEmail = "** N/A ** "
End If
' sends email with attachment
EmailMsgBody = "-- TOTAL # OF CONTRACTS WITH FAILSAFE DATE ON " + DateStr + " IS: " + icnt.ToString + vbCrLf +
vbNewLine + " __________________ " +
vbNewLine +
vbNewLine + " *****Contracts**** " +
vbNewLine + " __________________ " +
vbNewLine +
vbNewLine + "Contract#" + " " + "Vender Name" + " " + "Termination Date" + " " + "Dept Name" + " " + "Renewal Option" + " " + "Contract Desc" + " " + "Email Address" +
vbNewLine + "------------" + " " + "-----------------" + " " + "---------------------" + " " + "--------------" + " " + "--------------------" + " " + "-----------------" + " " + "-----------------" +
vbNewLine + ContractNo.PadRight(18) + " " + _
VenderName.PadRight(38) + " " + _
TerminationDateStr.PadRight(26) + " " + _
DeptName.PadRight(27) + " " + _
RenewalOption.PadRight(45) + " " + _
ContractDesc.PadRight(32) + " " + _
ContactEmail.PadRight(11) + " "