5
\$\begingroup\$

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
\$\endgroup\$
6
  • 4
    \$\begingroup\$ For doing things by the book, feel free to read the book on asking questions. Welcome to Code Review! \$\endgroup\$ – Mast Mar 30 '20 at 14:34
  • 2
    \$\begingroup\$ You're doing great! May I suggest editing though, to have all the code of a module in the same code block? Makes it much easier for reviewers to copy the code into their IDE. Having multiple blocks like this might also be hiding indentation issues. \$\endgroup\$ – Mathieu Guindon Mar 31 '20 at 0:50
  • \$\begingroup\$ Thanks! That makes a lot of sense. I actually thought about it, but I was scared that lack of commenting would be ill received. Should I edit it and provide a box with the full code? \$\endgroup\$ – Peder C Mar 31 '20 at 6:42
  • \$\begingroup\$ Don't worry about whether your code looks bad. Just post it as-is, how it currently is in your editor. The whole deal, that's fine. \$\endgroup\$ – Mast Mar 31 '20 at 7:33
  • 1
    \$\begingroup\$ Hi @TaylorScott, Just saw your answer. Thank you so much. I'll try it out :-)! \$\endgroup\$ – Peder C Aug 19 '20 at 7:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.