Application-defined or object-defined error in Excel VBA - excel

I'm getting said error in using VBA in Excel on the following code:
Private Sub XMLGen(mapRangeA, mapRangeB, ticketSize, mapping)
Dim fieldOneArr As Variant
Dim fieldTwoArr As Variant
Dim row As Long
Dim column As Long
Dim infoCol As Long
Dim endInfo As Long
Dim objDom As DOMDocument
Dim objNode As IXMLDOMNode
Dim objXMLRootelement As IXMLDOMElement
Dim objXMLelement As IXMLDOMElement
Dim objXMLattr As IXMLDOMAttribute
Set ws = Worksheets("StockData")
Dim wsName As String
Set objDom = New DOMDocument
If ticketSize = 8 Then
wsName = "A7Tickets"
ElseIf ticketSize = 16 Then
wsName = "A8Tickets"
Else
wsName = "A5Tickets"
End If
Set ps = Worksheets(wsName)
'create processing instruction
Set objNode = objDom.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
objDom.appendChild objNode
'create root element
Set objXMLRootelement = objDom.createElement("fields")
objDom.appendChild objXMLRootelement
'create Attribute to the Field Element and set value
Set objXMLattr = objDom.createAttribute("xmlns:xfdf")
objXMLattr.NodeValue = "http://ns.adobe.com/xfdf-transition/"
objXMLRootelement.setAttributeNode objXMLattr
infoCol = 1
fieldOneArr = Worksheets(mapping).range(mapRangeA)
fieldTwoArr = Worksheets(mapping).range(mapRangeB)
For row = 1 To UBound(fieldOneArr, 1)
For column = 1 To UBound(fieldOneArr, 2)
'create Heading element
Set objXMLelement = objDom.createElement(fieldOneArr(row, column))
objXMLRootelement.appendChild objXMLelement
'create Attribute to the Heading Element and set value
Set objXMLattr = objDom.createAttribute("xfdf:original")
objXMLattr.NodeValue = (fieldTwoArr(row, column))
objXMLelement.setAttributeNode objXMLattr
objXMLelement.Text = ps.Cells(row, infoCol)
infoCol = infoCol + 1
endInfo = endInfo + 1
If endInfo = 4 Then
infoCol = 1
End If
Next column
Next row
'save XML data to a file
If ticketSize = 2 Then
objDom.Save ("C:\ExportTestA5.xml")
MsgBox "A5 XML created"
ElseIf ticketSize = 8 Then
objDom.Save ("C:\ExportTestA7.xml")
MsgBox "A7 XML created"
Else
objDom.Save ("C:\ExportTestA8.xml")
MsgBox "A8 XML created"
End If
End Sub
When I hit debug it points to this line:
fieldOneArr = Worksheets(mapping).range(mapRangeA)
I know that .Range is supposed to be upper case but it keeps on setting it to lower case automatically whenever I correct it.
This code is meant to create an XML file and then write the details from the chosen worksheet (based on the ticketSize variable) into the correct XML fields. Hence I have a mapping worksheet from which I write the field and attribute names, and then write in the info from the correct ticket size worksheet into the text property of the element.

You should define the types of your function parameters, in this case mapRangeA As String. Office object methods and properties are often not very helpful with their error messages, so it's better to have a type mismatch error if you have a problem with a parameter.

Related

Copy and paste picture from excel to word

I am trying to try another method that is not to export the images from excel and then import them to word.
This method makes use of copy and paste, however I have encountered a problem using different versions of Office. In some it pastes it as InlineShape and in another as Shape.
I don't know how to correctly reference a variable in the pasted image. I thought I could use something like set object = selection after pasting the image but it doesn't work.
The purpose of referencing it is to add a text that allows me to delete it if I insert an update of the same image.
For the inlineshape I have solved it using the InlineShape.Range.BookmarkID property but if it is a Shape object I don't know the way.
Could anyone help me?
Code:
Sub Copy_Paste_Image_Bookmark(sBookmark As String, sImage As String, Optional sSheet As String, Optional sWorkbook As String)
Dim xlApp As Excel.Application, xlWrk As Excel.Workbook, xlSht As Excel.Worksheet
Dim oShp As Excel.Shape
Set xlApp = GetObject(, "Excel.Application")
Set xlWrk = xlApp.Workbooks(sWorkbook)
Set xlSht = xlWrk.Worksheets(sSheet)
xlSht.Shapes(sImage).Copy
'Control for word
Dim docWord As Word.Document
Dim oBookmark As Bookmark, rBookmark As Word.Range, oInLiShp As Word.InlineShape
Dim lInLiShapes As Long, idx As Long, lInLiShapes_old As Long
Dim lShapes As Long, lShapes_old As Long, bIsInlineShape As Boolean, bIsShape As Boolean
Dim oShape As Word.Shape, oShapes As Word.Shapes
Set docWord = ThisDocument
'If exists bookmark
If docWord.Bookmarks.Exists(sBookmark) Then
Set oBookmark = docWord.Bookmarks(sBookmark)
Set rBookmark = oBookmark.Range
'Delete previous text
'rBookmark.MoveEndUntil Chr(46), wdForward 'chr(12) jump page
rBookmark.Expand Unit:=wdParagraph
rBookmark.MoveEnd Unit:=wdCharacter, Count:=-1
If StrComp(rBookmark.Text, "Text test") = 0 Then rBookmark.Delete
'Delete previous image
idx = GetIndex_Inlishape_BookmarkID(oBookmark.Range.BookmarkID)
If idx > 0 Then docWord.InlineShapes(idx).Delete
'Recover count of shapes
lInLiShapes_old = docWord.InlineShapes.Count
lShapes_old = docWord.Shapes.Count
'Paste image
rBookmark.PasteAndFormat wdFormatOriginalFormatting
'Recover new count shapes
lInLiShapes = docWord.InlineShapes.Count
lShapes = docWord.Shapes.Count
'Determine type pasted shape
bIsInlineShape = lInLiShapes > lInLiShapes_old
bIsShape = lShapes > lShapes_old
'If is inlineshape
If bIsInlineShape And bIsShape = False Then
idx = GetIndex_Inlishape_BookmarkID(oBookmark.Range.BookmarkID)
Set oInLiShp = docWord.InlineShapes(idx)
ElseIf bIsShape And bIsInlineShape = False Then
Set oShape = docWord.Shapes(lShapes)
'Convert to inlineshape
Set oInLiShp = oShape.ConvertToInlineShape
Else
Exit Sub
End If
'Change some options
oInLiShp.Title = sImage
oInLiShp.Range.Paragraphs.Alignment = wdAlignParagraphCenter
Else
MsgBox "The bookmark " & sBookmark & " doesn't exist in the document.", vbOKOnly + vbCritical, "Not exists bookmark"
End If
End Sub
Function GetIndex_Inlishape_BookmarkID(bkm_ID As Long) As Long
Dim o As InlineShape, i As Long
For Each o In ThisDocument.InlineShapes
i = i + 1
If o.Range.BookmarkID = bkm_ID Then
Select Case o.Type
Case wdInlineShapePicture
GetIndex_Inlishape_BookmarkID = i
Exit Function
End Select
End If
Next
GetIndex_Inlishape_BookmarkID = 0
End Function
Solved with Set oShape = docWord.Shapes(sImage) because image pasted keep the name of shape from Excel although with .count of the collection Shapes run fine.
However with .count of the collection inlineshapes not run fine because Word orders the elements, first the shapepictures and after shapecharts.
Thanks.

VBA to extract file information, add any new information after last row of data

Sub GetFileList()
Dim xFSO As Object
Dim xFolder As Object
Dim xFile As Object
Dim objOL As Object
Dim Msg As Object
Dim xPath As String
Dim thisFile As String
Dim i As Integer
Dim lastrow As Long
xPath = Sheets("UI").Range("D7")
Set xFSO = CreateObject("Scripting.FileSystemObject")
Set xFolder = xFSO.GetFolder(xPath)
i = 1
For Each xFile In xFolder.Files
i = i + 1
Worksheets("Info").Cells(i, 1) = xPath
Worksheets("Info").Cells(i, 2) = Left(xFile.Name, InStrRev(xFile.Name, ".") - 1)
Worksheets("Info").Cells(i, 3) = Mid(xFile.Name, InStrRev(xFile.Name, ".") + 1)
Worksheets("Info").Cells(i, 6) = Left(FileDateTime(xFile), InStrRev(FileDateTime(xFile), " ") - 1)
Next
Set Msg = Nothing
Worksheets("Info").Visible = True
Worksheets("Info").Activate
End Sub
The code to extract file information from a folder. The issue is when I change the folder path, it overwrites on the previously fetched data.
Sheet -UI is where the sub executed on press of button, Sheet Info is the place where the data needs to be pasted.
How to write the code to add a new row of data after the data which is already available. If the sheet is blank then add data from the 1st ROW otherwise add data from the LAST ROW.
Sheets("UI").Range("A1").End(xlDown).Select
i = Selection.Row + 1
Try replacing
i = 1
with
i = Worksheets("Info").UsedRange.Rows.Count + 1
This will set i to 1 the first time around, and to the first free row ever after. New data will be added below the existing data, if there is any.

How to handle and get values from dynamic tags from XML file in VBA macro

I have an XML file with 3 levels. Some of the tags are dynamic.(Please check below XML file)
I have to validate whether the tag "price" is present in all nodes or not and also need to get value of "price tag". I also need to fetch a value of every node present in XML file.
I tried validating whether every node in XML file is present or not but getting an error
VBA code snippet
Function fnReadXMLByTags2()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Dim obj As Object
Set obj = CreateObject("MSXML2.DOMDocument")
obj.async = False
XMLFileName = "C:\Prakash\Demo.xml"
obj.Load (XMLFileName)
Set authorNodes = obj.SelectNodes("//Books/book/author/text()")
Set titleNodes = obj.SelectNodes("//Books/book/title/text()")
Set genreNodes = obj.SelectNodes("//Books/book/genre/text()")
Set priceNodes = obj.SelectNodes("//Books/book/price/text()")
Set publish_dateNodes = obj.SelectNodes("//Books/book/publish_date/text()")
Set languageNodes = obj.SelectNodes("//Books/book/language/text()")
For i = 0 To (authorNodes.Length - 1)
If Not publish_dateNodes Is Nothing Then
Set publish_dateNodesValue = obj.SelectNodes("//Books/book/publish_date/text()")
publish_dateObj = publish_dateNodesValue(i).NodeValue
mainWorkBook.Sheets("Sheet3").Range("E" & i + 2).Value = publish_dateObj
Else
mainWorkBook.Sheets("Sheet3").Range("E" & i + 2).Value = "Blank"
End If
Next
End Function
Below error Message for line …
publish_dateObj = publish_dateNodesValue(i).NodeValue
Runtime error '91':
Object variable or With block variable not set
This is what I'm expecting in Excel file:
Excel sheet output
Below is the xml file :
<?xml version="1.0"?>
<Books>
<book id="1">
<author>ABC</author>
<title>Physics</title>
<genre>asd</genre>
<price>Rs.44</price>
<publish_date>20-10-2001</publish_date>
<description>Book1</description>
</book>
<book id="2">
<author>DEF</author>
<title>Chem</title>
<genre>XYZ</genre>
<publish_date>02-12-2016</publish_date>
<description>Book2</description>
</book>
<book id="3">
<author>GHI</author>
<title>Maths</title>
<genre>ABC</genre>
<price>Rs.500</price>
<language>English</language>
<description>Book3</description>
</book>
</Books>
It should be a procedure (Sub) not a function, because it does not return a value (make sure you know the difference).
The way you read the sub nodes made it impossible to keep the data consitent. You need to read all books first and then for each book the sub nodes:
Set CurrentNode = Books(iBook).SelectNodes("author/text()")(0)
The above reads reads the node author from book number iBook into CurrentNode and if it does not exist then CurrentNode will be Nothing. So you just need to check it and output the .NodeValue.
Note that I introduced an array NodesOutputList to be able to loop through the columns easily instead of repeating similar code over and over.
So you end up with something like:
Option Explicit
Public Sub fnReadXMLByTags2()
Dim mainWorkBook As Workbook
Set mainWorkBook = ThisWorkbook '<-- this is the workbook where this code is in ActiveWorkbook is the worbkook that has focus (is on top)
Dim wsOutput As Worksheet 'define output sheet
Set wsOutput = mainWorkBook.Worksheets("Sheet3")
Dim XMLFileName As String
XMLFileName = "D:\code\Demo.xml"
Dim obj As Object
Set obj = CreateObject("MSXML2.DOMDocument")
obj.async = False
obj.Load XMLFileName '<-- no parenthesis here!!!
Dim Books As Object 'get all books
Set Books = obj.SelectNodes("//Books/book")
Dim NodesOutputList() As Variant 'order in which the nodes are checked and output
NodesOutputList = Array("author/text()", "title/text()", "genre/text()", "price/text()", "publish_date/text()", "language/text()", "description/text()")
Dim iBook As Long
For iBook = 0 To Books.Length - 1 'loop through books
Dim iNode As Long
For iNode = LBound(NodesOutputList) To UBound(NodesOutputList) 'loop through nodes in the list
Dim CurrentNode As Object
Set CurrentNode = Books(iBook).SelectNodes(NodesOutputList(iNode))(0)
If Not CurrentNode Is Nothing Then
wsOutput.Cells(iBook + 2, iNode + 1).Value = CurrentNode.NodeValue
Else
wsOutput.Cells(iBook + 2, iNode + 1).Value = "blank"
End If
Next iNode
Next iBook
End Sub

VBA Bloomberg API

I want to run a macro that brings me the following value INTERVAL_PERCENT_CHANGE from:
The ticher of the fund concerned S3.Range(Cells(3, 76), Cells(3, 77)).
Start and end dates S3.Cells(i, 73).Value and S3.Cells(i, 74).Value
Currency S3.Cells(2, 76).Value
from the Bloomberg APIs. But I get a soft error message
"invalid procedure call or argument".
I really tried everything but there is something that escapes me.
the underlined line is the following:
range(cells(4,76),cells(12,77)).value msg.GetElement("securitydata").GetValue(0).GetElement("fieldData").GetElement("INTERVAL_PERCENT_CHANGE").Value
Thank you for all your answers and insights. below the code in full
Sub ref_data()
Dim session As blpapicomLib2.session
Set session = New session
session.Start
Dim Service As blpapicomLib2.Service
session.OpenService ("//blp/refdata")
Set Service = session.GetService("//blp/refdata")
Dim Request As blpapicomLib2.Request
Set Request = Service.CreateRequest("ReferenceDataRequest")
Request.Append "securities", "S3.Range(Cells(3, 76), Cells(3, 77)).Value"
Request.Append "fields", "INTERVAL_PERCENT_CHANGE"
Dim overrides As Element
Set overrides = Request.GetElement("overrides")
Dim override As Element
Set override = overrides.AppendElment
Dim i As Integer
For i = 4 To 12
Dim override1 As Element
Set override1 = overrides.AppendElment
override1.SetElement "fieldId", "Start_Date_Override"
override1.SetElement "value", "S3.Cells(i, 73).Value" 'Replace date with the cell reference eg Range("B10").Value
Dim override2 As Element
Set override2 = overrides.AppendElment
override2.SetElement "fieldId", "End_Date_Override"
override2.SetElement "value", "S3.Cells(i, 74).Value" 'Replace date with the cell reference eg Range("A10").Value
Dim override3 As Element
Set override3 = overrides.AppendElment
override3.SetElement "fieldId", "CRNCY"
override3.SetElement "value", "S3.Cells(2, 76).Value" 'Replace EUR with the cell reference eg Range("A10").Value
session.SendRequest Request
Dim blpevent As blpapicomLib2.Event
Dim it As blpapicomLib2.MessageIterator
Dim msg As blpapicomLib2.Message
Dim finalResponse As Boolean
Do While finalResponse = False
Set blpevent = session.NextEvent
Set it = blpevent.CreateMessageIterator
Do While it.Next
Set msg = it.Message
If blpevent.EventType = RESPONSE Or blpevent.EventType = PARTIAL_RESPONSE Then
range(cells(4,76),cells(12,77)).value msg.GetElement("securitydata").GetValue(0).GetElement("fieldData").GetElement("INTERVAL_PERCENT_CHANGE").Value
End If
If blpevent.EventType = RESPONSE Then
finalResponse = True
End If
Loop
Loop
Next i
End Sub

Problems calling Function with Argument (Need to pass File name from one function to another) Excel VBA

I am trying to integrate 2 functions.
I have one sub function which works to loop through all files one by one.
once it has identified the file name.
It should call the function to run, on the opened file.
I can not seem to find a way to pass this on,
I did some reading on calling functions with arguments but when i try this i get a "compile error seperate list or )"
Can you please point me in the right direction?
I have posted the code below:
Option Explicit
Option Base 1
Public Const DATASHEET As String = "MDFDATA"
Public Const TABLECONVERSIONSHEET As String = "TABLECONVERSION"
Public Const OPTIONSSHEET As String = "OPTIONS"
Public Const FinalSheet As String = "Final Sheet"
Public lByte_Order As Long 'byte order
Public lData_Groups As Long 'number of data groups
Public lChannel_Groups As Long 'number of channel groups
Public lChannels As Long 'number of channels
Public lTable_offset As Long 'row offset for the conversion table sheet
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim sFile_Name As String 'MDF file name
Dim lFile_Number As Long 'file number
MyFolder = "C:\Users\Documents\Test"
sFile_Name = Dir(MyFolder & "\*.dat")
Do While sFile_Name <> ""
lFile_Number = FreeFile
Open sFile_Name For Binary Access Read Shared As lFile_Number
Call PARSE_MDF
Loop
End Sub
'==================================================================================================
' PARSE_MDF
' Main function
' Returns True if successful
'==================================================================================================
Function PARSE_MDF() As Boolean
Dim sFile_Name As String 'MDF file name
Dim lFile_Number As Long 'file number
Dim lData_Groups_Counter As Long 'data groups counter
Dim lChannel_Groups_Counter As Long 'channel groups counter
Dim lChannels_Counter As Long 'channels counter
Dim lRecords As Long 'number of records in data block
Dim lRecord_Length As Long 'length of record in data block
Dim lData_Group_Address As Long 'data group address
Dim lData_Address As Long 'data address
Dim lChannel_Group_Address As Long 'Channel group address
Dim lChannel_Address As Long 'Channel address
Dim byCol As Byte 'column counter for output
Dim wsData_Sheet As Worksheet 'main worksheet
Dim wsTable_Conversion_Sheet As Worksheet
Dim rFirst_Signal As Range 'first signal in channel group
Dim rLast_Signal As Range 'last signal in channel group
Dim rSignals As Range 'range of signal names for a channel group
Application.EnableEvents = False
lTable_offset = 0
Set wsTable_Conversion_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(TABLECONVERSIONSHEET)
Set wsData_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(DATASHEET)
'file selected
If sFile_Name <> "False" Then
'clear old data
wsData_Sheet.Columns.Clear
wsTable_Conversion_Sheet.Columns.ClearContents
'set headers
wsData_Sheet.Cells(1, 1).Value = "Signal name"
wsData_Sheet.Cells(2, 1).Value = "Data type"
wsData_Sheet.Cells(3, 1).Value = "Lsb"
wsData_Sheet.Cells(4, 1).Value = "Offset"
wsData_Sheet.Cells(5, 1).Value = "Bit length"
wsData_Sheet.Cells(6, 1).Value = "Formula ID"
wsData_Sheet.Cells(7, 1).Value = "Formula"
wsData_Sheet.Cells(8, 1).Value = "First Bit position"
wsData_Sheet.Cells(9, 1).Value = "Table length"
wsData_Sheet.Cells(10, 1).Value = "Start Row"
'offset columns because of headers
byCol = 2
'get file number
lFile_Number = FreeFile
'open file
'check file integrity
If IDBLOCK(lFile_Number) Then
'check data exists
If HDBLOCK(lFile_Number, lData_Group_Address) Then
'main iteration for data groups
For lData_Groups_Counter = 1 To lData_Groups
'check channel group exists
If DGBLOCK(lFile_Number, lData_Group_Address, lChannel_Group_Address, lData_Address) Then
'channel group iteration
For lChannel_Groups_Counter = 1 To lChannel_Groups
'get channel group data
Call CGBLOCK(lFile_Number, lChannel_Group_Address, lChannel_Address, lRecord_Length, lRecords)
'set the first signal range in this channel group
Set rFirst_Signal = wsData_Sheet.Cells(1, byCol)
'channels iteration
For lChannels_Counter = 1 To lChannels
'get channel data for each channel
Call CNBLOCK(lFile_Number, lChannel_Address, wsData_Sheet, byCol)
'excel fudge
If byCol <> 255 Then
byCol = byCol + 1
End If
Next 'lChannels_Counter
'set the last signal range in this channel group
Set rLast_Signal = wsData_Sheet.Cells(1, byCol - 1)
'format divider columns
wsData_Sheet.Columns(byCol).ColumnWidth = 5
wsData_Sheet.Columns(byCol).Interior.ColorIndex = 0
wsData_Sheet.Columns(byCol).Interior.Pattern = xlLightUp
wsData_Sheet.Columns(byCol).Interior.PatternColorIndex = xlAutomatic
'excel fudge
If byCol <> 255 Then
'for space between channels
byCol = byCol + 1
End If
Next 'lChannel_Groups_Counter
'get range of signals to get data for
Set rSignals = wsData_Sheet.Range(rFirst_Signal, rLast_Signal)
'get signal data
'no channel data in this data group
Else
PARSE_MDF = False
End If
Next 'lData_Groups_Counter
'no data in MDF file
Else
PARSE_MDF = False
End If
'not a MDF file
Else
PARSE_MDF = False
End If
'close file
Close #lFile_Number
'tidy up sheet
wsData_Sheet.Rows.EntireRow.AutoFit
wsData_Sheet.Columns.EntireColumn.AutoFit
wsData_Sheet.Rows("2:15").EntireRow.Delete
wsData_Sheet.Columns("A:A").EntireColumn.Delete
wsData_Sheet.Cells.HorizontalAlignment = xlCenter
'function ends normally
PARSE_MDF = True
'no file was selected
Else
PARSE_MDF = False
End If
Application.EnableEvents = True
End Function
What you need to do is to pass the found filename as argument to the function. Now your function does not have an argument to pass it on so first of all create one such for ex.
Function PARSE_MDF(ByVal myFilePath as String) As Boolean
Then you need to change your loop to call the function correctly for ex.
Do While sFile_Name <> ""
....
myboolenvaluetohodthereturnvalue = PARSE_MDF(sFile_Name)
.... 'does your funtion need to return value and be tested?
sFile_Name = Dir() 'Call dir again without parameter to skip to next found file
Loop
Otherwise I haven't checked your code but this should get you started..

Resources