none
parse xml that i go from webserver and write it to excel takeking to much time RRS feed

  • Question

  • Hi,

    I am trying to write to a excel more 50000 rows that etch row have 11 cells it;s taking me more them 18 minutes to do so.

    can somebody tell me what am I am doing wrong??

    Thanks Itay

    public Sub updateResultsSheet()
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim NewBook As Excel.Workbook: Set NewBook = ActiveWorkbook
    Dim suppDistBranchId As String
    Dim suppProdId As String
    Dim reportingDate As String
    Dim query As String
    Dim nodeCell As IXMLDOMNode
    Dim rowCount As Integer
    Dim cellCount As Integer
    Dim rowRange As Range
    Dim cellRange As Range
    rowCount = 1
    query = "http://******:8080/RS_Excel_API/dailyInvHist/get/1?"
    reportingDate = Trim(Range("Parameters!F" + CStr(2)).Value & vbNullString)
     query = query + "reportingDate="
     query = query + reportingDate
    Dim Req As New XMLHTTP
    Req.Open "GET", query, False
    Req.send
    Dim Resp As New DOMDocument
    Resp.LoadXML Req.responseText
    Dim InventoyHistory As IXMLDOMNode
    
    'Sub WriteTaskDataToExcel()
    
    'Dim xlApp As Excel.Application
    'Set xlApp = New Excel.Application
    Application.Visible = True
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ws.DisplayPageBreaks = False
    
    'Dim NewBook As Excel.Workbook
    'Dim ws As Excel.Worksheet
    'Set NewBook = xlApp.Workbooks.Add()
    'With NewBook
         '.Title = "SomeData"
        ' Set ws = NewBook.Worksheets.Add()
         'ws.Name = "SomeData"
    'End With
    
    Dim OrigCalc As Excel.XlCalculation
    OrigCalc = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Const BlockSize As Long = 1000
    Dim Values() As Variant
    ReDim Values(BlockSize, 11)
    Dim idx As Long
    idx = 1
    Dim RowNumber As Long
    RowNumber = 2
    'Dim tsk As Task
    Dim celInx As Integer
    dim array(
    Resp.getElementsByTagName ("DailyInventoryHistory")
    celInx = 0
     Dim StartTime As Double
      StartTime = Timer
     For Each InventoyHistory In Resp.getElementsByTagName("DailyInventoryHistory")
    celInx = 0
        For Each nodeCell In InventoyHistory.ChildNodes
            Values(idx, celInx) = nodeCell.nodeTypedValue
            celInx = celInx + 1
        Next nodeCell
        idx = idx + 1
        If idx = BlockSize - 1 Then
            With ws
                .Range(.Cells(RowNumber, 1), .Cells(RowNumber + BlockSize - 1, 11)).Value = Values
            End With
            idx = 1
            ReDim Values(BlockSize, 11)
            RowNumber = RowNumber + BlockSize
        End If
    Next
    ' write last block
    With ws
        .Range(.Cells(RowNumber, 1), .Cells(RowNumber + BlockSize - 1, 11)).Value = Values
    End With
    Application.ScreenUpdating = True
    Application.Calculation = OrigCalc
    Application.Visible = True
    
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    ws.DisplayPageBreaks = True
     MsgBox Format(Timer - StartTime, "0000.00") & " seconds"
    
    End Sub
    

    Thursday, February 4, 2016 9:54 PM

Answers