EDIT: Added a block with the raw code at the bottom (suggested by a friendly user)
First post here. I sincerely hope that I am doing everything by the book. Also, I want to thank you in advance for any help and assistance that you may be able to provide me. I have been coding VBA for 2 weeks.
Problem: What can I do to make my code faster? I am certain it can be better and I've looked up a few things that I want to go ahead and test. I know the use of array is awesome, but I am not sure if it is needed here? I also know that my loops are causing a bottleneck, but I am not sure what a better alternative would be.
Again, THANK YOU.
The XML format looks like this:
<xmldata> <products> <rownumber></rownumber> <pkid></pkid> <category></category> <description> </description> <header> </header> <instock></instock> <keywords> </keywords> <deliverytime></deliverytime> <priceretail></priceretail> <kostprice></kostprice> <productid></productid> <unit></unit> <volume></volume> <weight></weight> <usr_sca_length></usr_sca_length> <usr_sca_width></usr_sca_width> <usr_sca_height></usr_sca_height> <manufacturer></manufacturer> </products> </xmldata> Full Code with comments:
Sub GetAPI() Turns off stuff and clears sheets before going
Call ClearCells Call TurnOffShit LOAD API
Dim ws As Worksheet: Set ws = Worksheets("API") Dim strURL As String Dim strURLMain As String Dim strURLUser As String Dim strURLPassword As String Dim strURLIndex As String Dim strURLPage As String Dim strURLEnd As String Dim lastRow As Integer Constructing URL CUT OUT DETAILS. In this bit I store number of rows (10.000) and starting page (1) of API. More on why I chose 10.000 later in the comments
strURLMain = "" strURLUser = "" strURLPassword = "" strURLIndex = "" strURLPage = "1" strURLEnd = "" strURL is my startpage: I loop on this later until it = xmlLastPage
strURL = strURLMain & strURLUser & ":" & strURLPassword & strURLIndex & strURLPage & strURLEnd Debug.Print "" Debug.Print "API URL er: "; strURL Debug.Print "" Get API Response Data – this first one is to determine xmlLastPage – last page of API at given rows'
Dim httpRequest As New WinHttpRequest httpRequest.SetTimeouts 0, 0, 0, 0 httpRequest.Open "GET", strURL, False httpRequest.Send Dim strResponse As String strResponse = httpRequest.ResponseText Output API Data Response into XML
Dim xmlDoc As New MSXML2.DOMDocument60 Dim xmldata As MSXML2.IXMLDOMNodeList, paging As MSXML2.IXMLDOMNode Dim xmlpagesElement As MSXML2.IXMLDOMElement xmlDoc.SetProperty "SelectionLanguage", "XPath" xmlDoc.SetProperty "SelectionNamespaces", "" If Not xmlDoc.LoadXML(strResponse) Then MsgBox "Indlæsningsfejl ved afsnit 1.4" End If Finds the last page in our API. Our API crash at > 10.000 so I had to find a way to loop through the pages at a given # of rows From conducting a basic time analysis on the different stages of the code, I concluded that Loops take up time and hence I want to minimize them (a max of 10.000 # of rows was hereby chosen)
Dim xmlPage As Integer Dim xmlFirstPage As Integer xmlFirstPage = 1 Set xmlpagesElement = xmlDoc.SelectSingleNode("xmldata/paging/pages[1]") xmlLastPage = xmlpagesElement Debug.Print "" Debug.Print "Lastpage i XML/API er: "; xmlpagesElement.nodeTypedValue Debug.Print "" Loop through API pages one by one untill we hit and retrieve last page (xmlLastPage) and get product data
For xmlPage = xmlFirstPage To xmlLastPage Get API Response Data – made another request to make it easier for me to loop on API pages
Dim httpRequest2 As New WinHttpRequest Dim strResponse2 As String strURL2 = strURLMain & strURLUser & ":" & strURLPassword & strURLIndex & xmlPage & strURLEnd httpRequest2.SetTimeouts 0, 0, 0, 0 httpRequest2.Open "GET", strURL2, False httpRequest2.Send strResponse2 = httpRequest2.ResponseText Output API Data Response into XML
Dim xmlDoc2 As New MSXML2.DOMDocument60 Dim xmldata2 As MSXML2.IXMLDOMNodeList, products As MSXML2.IXMLDOMNode xmlDoc.SetProperty "SelectionLanguage", "XPath" xmlDoc.SetProperty "SelectionNamespaces", "" If Not xmlDoc2.LoadXML(strResponse2) Then MsgBox "Indlæsningsfejl ved afsnit 1." End If Get Productdata
Set xmldata2 = xmlDoc2.SelectNodes("xmldata/products") Debug.Print "Antal produkter fundet (på siden)", xmldata2.Length Insert product data on rows Doing the below loop to prevent errors. Slow. Other way to do it? I could for sure delete some of them, as some value will always be there (rownumber). “Description”, for instance is not always in a node and hence will throw an error
For Each products In xmldata2 lastRow = (Cells(Rows.Count, 2).End(xlUp).Row) + 1 Set pRowNumber = products.SelectSingleNode("rownumber") If Not pRowNumber Is Nothing Then Cells(lastRow, 2).Value = pRowNumber.Text Else Cells(lastRow, 2).Value = "<tom>" End If Set pCategory = products.SelectSingleNode("category") If Not pCategory Is Nothing Then Cells(lastRow, 3).Value = pCategory.Text Else Cells(lastRow, 3).Value = "<tom>" End If Set pDescription = products.SelectSingleNode("description") If Not pDescription Is Nothing Then Cells(lastRow, 4).Value = pDescription.Text Else Cells(lastRow, 4).Value = "<tom>" End If Set pHeader = products.SelectSingleNode("header") If Not pHeader Is Nothing Then Cells(lastRow, 5).Value = pHeader.Text Else Cells(lastRow, 5).Value = "<tom>" End If Set pInstock = products.SelectSingleNode("instock") If Not pInstock Is Nothing Then Cells(lastRow, 6).Value = pInstock.Text Else Cells(lastRow, 6).Value = "<tom>" End If Set pKeyword = products.SelectSingleNode("keywords") If Not pKeyword Is Nothing Then Cells(lastRow, 7).Value = pKeyword.Text Else Cells(lastRow, 7).Value = "<tom>" End If Set pPriceretail = products.SelectSingleNode("priceretail") If Not pPriceretail Is Nothing Then Cells(lastRow, 8).Value = pPriceretail.Text Else Cells(lastRow, 8).Value = "<tom>" End If Set pKostprice = products.SelectSingleNode("kostprice") If Not pKostprice Is Nothing Then Cells(lastRow, 9).Value = pKostprice.Text Else Cells(lastRow, 9).Value = "<tom>" End If Set pProductid = products.SelectSingleNode("productid") If Not pProductid Is Nothing Then Cells(lastRow, 10).Value = pProductid.Text Else Cells(lastRow, 10).Value = "<tom>" End If Set pUnit = products.SelectSingleNode("unit") If Not pUnit Is Nothing Then Cells(lastRow, 11).Value = pUnit.Text Else Cells(lastRow, 11).Value = "<tom>" End If Set pVolume = products.SelectSingleNode("volume") If Not pVolume Is Nothing Then Cells(lastRow, 12).Value = pVolume.Text Else Cells(lastRow, 12).Value = "<tom>" End If Set pWeight = products.SelectSingleNode("weight") If Not pWeight Is Nothing Then Cells(lastRow, 13).Value = pWeight.Text Else Cells(lastRow, 13).Value = "<tom>" End If Set pEan = products.SelectSingleNode("ean") If Not pEan Is Nothing Then Cells(lastRow, 14).Value = pEan.Text Else Cells(lastRow, 14).Value = "<tom>" End If Set pUsrScaLength = products.SelectSingleNode("usr_sca_length") If Not pUsrScaLength Is Nothing Then Cells(lastRow, 15).Value = pUsrScaLength.Text Else Cells(lastRow, 15).Value = "<tom>" End If Set pUsrScaWidth = products.SelectSingleNode("usr_sca_width") If Not pUsrScaWidth Is Nothing Then Cells(lastRow, 16).Value = pUsrScaWidth.Text Else Cells(lastRow, 16).Value = "<tom>" End If Set pUsrScaHeight = products.SelectSingleNode("usr_sca_height") If Not pUsrScaHeight Is Nothing Then Cells(lastRow, 17).Value = pUsrScaHeight.Text Else Cells(lastRow, 17).Value = "<tom>" End If Set pYoutube = products.SelectSingleNode("youtube") If Not pYoutube Is Nothing Then Cells(lastRow, 18).Value = pYoutube.Text Else Cells(lastRow, 18).Value = "<tom>" End If Next products Next xmlPage Call TurnOnShit End Sub Sub TurnOffShit() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.EnableEvents = False End Sub Sub TurnOnShit() Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub Sub ClearCells() Range("B3:R200000").Clear End Sub Raw Code
Sub GetAPI() Call ClearCells Call TurnOffShit Dim ws As Worksheet: Set ws = Worksheets("API") Dim strURL As String Dim strURLMain As String Dim strURLUser As String Dim strURLPassword As String Dim strURLIndex As String Dim strURLPage As String Dim strURLEnd As String Dim lastRow As Integer strURLMain = "" strURLUser = "" strURLPassword = "" strURLIndex = "" strURLPage = "1" strURLEnd = "" strURL = strURLMain & strURLUser & ":" & strURLPassword & strURLIndex & strURLPage & strURLEnd Debug.Print "" Debug.Print "API URL er: "; strURL Debug.Print "" Dim httpRequest As New WinHttpRequest httpRequest.SetTimeouts 0, 0, 0, 0 httpRequest.Open "GET", strURL, False httpRequest.Send Dim strResponse As String strResponse = httpRequest.ResponseText Dim xmlDoc As New MSXML2.DOMDocument60 Dim xmldata As MSXML2.IXMLDOMNodeList, paging As MSXML2.IXMLDOMNode Dim xmlpagesElement As MSXML2.IXMLDOMElement xmlDoc.SetProperty "SelectionLanguage", "XPath" xmlDoc.SetProperty "SelectionNamespaces", "" If Not xmlDoc.LoadXML(strResponse) Then MsgBox "Indlæsningsfejl ved afsnit 1.4" End If Dim xmlPage As Integer Dim xmlFirstPage As Integer xmlFirstPage = 1 Set xmlpagesElement = xmlDoc.SelectSingleNode("xmldata/paging/pages[1]") xmlLastPage = xmlpagesElement Debug.Print "" Debug.Print "Lastpage i XML/API er: "; xmlpagesElement.nodeTypedValue Debug.Print "" For xmlPage = xmlFirstPage To xmlLastPage Dim httpRequest2 As New WinHttpRequest Dim strResponse2 As String strURL2 = strURLMain & strURLUser & ":" & strURLPassword & strURLIndex & xmlPage & strURLEnd httpRequest2.SetTimeouts 0, 0, 0, 0 httpRequest2.Open "GET", strURL2, False httpRequest2.Send strResponse2 = httpRequest2.ResponseText Dim xmlDoc2 As New MSXML2.DOMDocument60 Dim xmldata2 As MSXML2.IXMLDOMNodeList, products As MSXML2.IXMLDOMNode xmlDoc.SetProperty "SelectionLanguage", "XPath" xmlDoc.SetProperty "SelectionNamespaces", "" '' If Not xmlDoc2.LoadXML(strResponse2) Then MsgBox "Indlæsningsfejl ved afsnit 1." End If Set xmldata2 = xmlDoc2.SelectNodes("xmldata/products") Debug.Print "Antal produkter fundet (på siden)", xmldata2.Length For Each products In xmldata2 lastRow = (Cells(Rows.Count, 2).End(xlUp).Row) + 1 Set pRowNumber = products.SelectSingleNode("rownumber") If Not pRowNumber Is Nothing Then Cells(lastRow, 2).Value = pRowNumber.Text Else Cells(lastRow, 2).Value = "<tom>" End If Set pCategory = products.SelectSingleNode("category") If Not pCategory Is Nothing Then Cells(lastRow, 3).Value = pCategory.Text Else Cells(lastRow, 3).Value = "<tom>" End If Set pDescription = products.SelectSingleNode("description") If Not pDescription Is Nothing Then Cells(lastRow, 4).Value = pDescription.Text Else Cells(lastRow, 4).Value = "<tom>" End If Set pHeader = products.SelectSingleNode("header") If Not pHeader Is Nothing Then Cells(lastRow, 5).Value = pHeader.Text Else Cells(lastRow, 5).Value = "<tom>" End If Set pInstock = products.SelectSingleNode("instock") If Not pInstock Is Nothing Then Cells(lastRow, 6).Value = pInstock.Text Else Cells(lastRow, 6).Value = "<tom>" End If Set pKeyword = products.SelectSingleNode("keywords") If Not pKeyword Is Nothing Then Cells(lastRow, 7).Value = pKeyword.Text Else Cells(lastRow, 7).Value = "<tom>" End If Set pPriceretail = products.SelectSingleNode("priceretail") If Not pPriceretail Is Nothing Then Cells(lastRow, 8).Value = pPriceretail.Text Else Cells(lastRow, 8).Value = "<tom>" End If Set pKostprice = products.SelectSingleNode("kostprice") If Not pKostprice Is Nothing Then Cells(lastRow, 9).Value = pKostprice.Text Else Cells(lastRow, 9).Value = "<tom>" End If Set pProductid = products.SelectSingleNode("productid") If Not pProductid Is Nothing Then Cells(lastRow, 10).Value = pProductid.Text Else Cells(lastRow, 10).Value = "<tom>" End If Set pUnit = products.SelectSingleNode("unit") If Not pUnit Is Nothing Then Cells(lastRow, 11).Value = pUnit.Text Else Cells(lastRow, 11).Value = "<tom>" End If Set pVolume = products.SelectSingleNode("volume") If Not pVolume Is Nothing Then Cells(lastRow, 12).Value = pVolume.Text Else Cells(lastRow, 12).Value = "<tom>" End If Set pWeight = products.SelectSingleNode("weight") If Not pWeight Is Nothing Then Cells(lastRow, 13).Value = pWeight.Text Else Cells(lastRow, 13).Value = "<tom>" End If Set pEan = products.SelectSingleNode("ean") If Not pEan Is Nothing Then Cells(lastRow, 14).Value = pEan.Text Else Cells(lastRow, 14).Value = "<tom>" End If Set pUsrScaLength = products.SelectSingleNode("usr_sca_length") If Not pUsrScaLength Is Nothing Then Cells(lastRow, 15).Value = pUsrScaLength.Text Else Cells(lastRow, 15).Value = "<tom>" End If Set pUsrScaWidth = products.SelectSingleNode("usr_sca_width") If Not pUsrScaWidth Is Nothing Then Cells(lastRow, 16).Value = pUsrScaWidth.Text Else Cells(lastRow, 16).Value = "<tom>" End If Set pUsrScaHeight = products.SelectSingleNode("usr_sca_height") If Not pUsrScaHeight Is Nothing Then Cells(lastRow, 17).Value = pUsrScaHeight.Text Else Cells(lastRow, 17).Value = "<tom>" End If Set pYoutube = products.SelectSingleNode("youtube") If Not pYoutube Is Nothing Then Cells(lastRow, 18).Value = pYoutube.Text Else Cells(lastRow, 18).Value = "<tom>" End If Next products Next xmlPage Call TurnOnShit End Sub Sub TurnOffShit() Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.EnableEvents = False End Sub Sub TurnOnShit() Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub Sub ClearCells() Range("B3:R200000").Clear End Sub 
