Hi all
Been trying to optimize this loop to run faster im exporting at list 20 000 records and it goes on forever... any tios
Kind regards,
Been trying to optimize this loop to run faster im exporting at list 20 000 records and it goes on forever... any tios
Code:
Sub ExportGridToExcel()
On Error GoTo ErrorHandler
Dim lngColCntr As Integer
Dim strPassedString As String
Dim lngTmpVar As Integer
Dim intPrevRow As Integer
Erase arrExport
blnSomethingExported = False
'check that to column >= to column
If (dblGridEndRow.Value < dblGridBeginRow.Value) Or (dblGridEndColumn.Value < dblGridBeginColumn.Value) Then
Call objGeneral.DisplayMessage(Qm.Enum.EnumMainFormNET.enumMessageType.msgtApplicationMessage, Qm.Enum.EnumMainFormNET.enumMessageSource.msgsDataBase, 60340, Me.Handle.ToInt32)
'End Row/Column may not be greater than Begin Row/Column.
Cursor = Cursors.Arrow
Exit Sub
End If
'array to indicate if columns are hidden or not; to minimise cross process calls
Erase ArrHiddenCol
ReDim ArrHiddenCol(dblGridEndColumn.Value)
intNumberOfColumnsToExport = 0
For lngColCntr = dblGridBeginColumn.Value To dblGridEndColumn.Value
objPassedControl.Col = lngColCntr - 1
ArrHiddenCol(lngColCntr) = objPassedControl.ColHidden
If chkHiddenGridCols.CheckState Then 'export all columns
intNumberOfColumnsToExport = intNumberOfColumnsToExport + 1
Else 'do not export hidden columns
If Not ArrHiddenCol(lngColCntr) Then intNumberOfColumnsToExport = intNumberOfColumnsToExport + 1
End If
Next lngColCntr
intNumberOfRowsToExport = dblGridEndRow.Value - dblGridBeginRow.Value + 1 'include the 0
'intNumberOfRowsToExport = dblGridEndRow.Value - dblGridBeginRow.Value + 1 'include the 0
' not to go over limitof control, amount of columns
ReDim arrExport(intArrayRows, intNumberOfColumnsToExport)
'convert starting cell to meaningfull numbers
If Not ValidStartingCell() Then
Cursor = Cursors.Arrow
Exit Sub
End If
If Not StartExcel() Then
Call objGeneral.DisplayMessage(Qm.Enum.EnumMainFormNET.enumMessageType.msgtApplicationMessage, Qm.Enum.EnumMainFormNET.enumMessageSource.msgsDataBase, 60341, Me.Handle.ToInt32)
'Application was not successfully started.
Cursor = Cursors.Arrow
Exit Sub
End If
intNextExportRowNumber = lngStartingRow
lngEndBlockRow = 0
lngStartBlockRow = 0
intRowCount = 0
intColumnCount = 0
intTotalRowCount = 0
intTotalRowsToWrite = 0
blnFirstExportFlag = False
'make sure that the block of data returned is no too big
'a string can have approx 2 billion chars but we limit it here to a constant
'intNumberOfRowsToExport has the number of rows to export
objPassedControl.BlockMode = True
objPassedControl.Col = dblGridBeginColumn.Value - 1
objPassedControl.Col2 = dblGridEndColumn.Value - 1
lngStartBlockRow = dblGridBeginRow.Value - 1
If lngStartBlockRow + intArrayRows > dblGridEndRow.Value - 1 Then
lngEndBlockRow = dblGridEndRow.Value - 1
Else
lngEndBlockRow = lngEndBlockRow + intArrayRows
End If
intPrevRow = -1
'intTotalRowCount has then next row to be but it started with 0 so it is the
'rows exported
Do While intTotalRowCount < intNumberOfRowsToExport 'still more to read
' MsgBox(" dblGridEndRow.Value To dblGridBeginRow.Value + 1 " & dblGridEndRow.Value & " " & dblGridBeginRow.Value + 1)
If intPrevRow = intTotalRowCount Then Exit Do
intPrevRow = intTotalRowCount
objPassedControl.BlockMode = True
lngPreviousStartBlockRow = lngStartBlockRow
objPassedControl.Row = lngStartBlockRow
objPassedControl.Row2 = lngEndBlockRow
lngStartBlockRow = lngEndBlockRow + 1
If lngStartBlockRow + intArrayRows > dblGridEndRow.Value - 1 Then 'adding arrayrows amount will be too much
lngEndBlockRow = dblGridEndRow.Value - 1
Else
lngEndBlockRow = lngStartBlockRow + intArrayRows
End If
' If lngEndBlockRow > 400 Then
' Beep
' End If
strPassedString = objPassedControl.Clip
objPassedControl.BlockMode = False
'find & remove all chr(10)'s in the string
'the grid puts a char(10) in front of every new line or on the end of each line
'it is captured here as on the beginning of each line
'make sure it is removed because it makes the spreadsheet row height too big
lngTmpVar = InStr(strPassedString, Chr(10))
Do While lngTmpVar <> 0
strPassedString = Mid(strPassedString, 1, lngTmpVar - 1) & Mid(strPassedString, lngTmpVar + 1)
lngTmpVar = InStr(strPassedString, Chr(10))
Loop
strPassedString = strPassedString & " " 'to cater for: strPassedString = Mid(strPassedString, InStr(strPassedString, Chr(13)) + 1)
If Len(Trim(strPassedString)) = 0 Then
intTotalRowCount = lngEndBlockRow
End If
lngColCntr = dblGridBeginColumn.Value
'find first tab in string
Do Until Len(Trim(strPassedString)) = 0
If InStr(1, strPassedString, Chr(13)) = 0 Then 'no more lines, at the last line
If InStr(1, strPassedString, Chr(9)) = 0 Then 'no more lines or tabs, busy with the last item
'not( hidden and not export hidden rows)
If Not (ArrHiddenCol(lngColCntr) And Not chkHiddenGridCols.CheckState) Then
arrExport(intRowCount, intColumnCount) = FormatString(strPassedString)
blnSomethingExported = True
intTotalRowCount = intTotalRowCount + 1
intTotalRowsToWrite = intTotalRowsToWrite + 1
End If
lngColCntr = lngColCntr + 1
strPassedString = ""
Else 'not busy with last item but with the last row so check for next chr(9)
If Not (ArrHiddenCol(lngColCntr) And Not chkHiddenGridCols.CheckState) Then
arrExport(intRowCount, intColumnCount) = FormatString(Mid(strPassedString, 1, InStr(strPassedString, Chr(9)) - 1))
blnSomethingExported = True
intColumnCount = intColumnCount + 1
End If
lngColCntr = lngColCntr + 1
strPassedString = Mid(strPassedString, InStr(1, strPassedString, Chr(9)) + 1)
End If
Else 'there are more rows still because there is a chr(13)
'see if hidden
objPassedControl.Row = intTotalRowCount
If objPassedControl.RowHidden And Not chkHiddenGridRows.CheckState Then
'dont export, take out row
strPassedString = Mid(strPassedString, InStr(strPassedString, Chr(13)) + 1)
intTotalRowCount = intTotalRowCount + 1
objPassedControl.Row = intTotalRowCount
'if there are more chr(13)'s in the string, loop further
'else you have the last row, determine if it is hidden or not
' if you do not you will increment the row and PassecControl.rowhidden will not be a valid check
If InStr(1, strPassedString, Chr(13)) <> 0 Then
'there are more rows, continue
Else 'has one row left, determine if it is hidden or not
If objPassedControl.RowHidden Then strPassedString = ""
End If
Else
'check if there are more chr(9)'s in the passedArray
If InStr(1, strPassedString, Chr(9)) <> 0 Then 'there are more data items separated by the chr(9)
'see if the tab(chr(9)) or the enter(chr(13)) comes first
If InStr(1, strPassedString, Chr(9)) < InStr(1, strPassedString, Chr(13)) Then 'there is another tab first
If Not (ArrHiddenCol(lngColCntr) And Not chkHiddenGridCols.CheckState) Then
arrExport(intRowCount, intColumnCount) = FormatString(Mid(strPassedString, 1, InStr(strPassedString, Chr(9)) - 1))
blnSomethingExported = True
intColumnCount = intColumnCount + 1
End If
lngColCntr = lngColCntr + 1
strPassedString = Mid(strPassedString, InStr(1, strPassedString, Chr(9)) + 1)
Else 'the enter chr(13) is before the tab chr(9)
If Not (ArrHiddenCol(lngColCntr) And Not chkHiddenGridCols.CheckState) Then
arrExport(intRowCount, intColumnCount) = FormatString(Mid(strPassedString, 1, InStr(strPassedString, Chr(13)) - 1))
blnSomethingExported = True
End If
strPassedString = Mid(strPassedString, InStr(1, strPassedString, Chr(13)) + 1)
intRowCount = intRowCount + 1
intTotalRowCount = intTotalRowCount + 1
intTotalRowsToWrite = intTotalRowsToWrite + 1
intColumnCount = 0
lngColCntr = dblGridBeginColumn.Value
objPassedControl.Row = intTotalRowCount
'if next row is hidden and must not be exported, remove it
Do While objPassedControl.RowHidden And Not chkHiddenGridRows.CheckState
strPassedString = Mid(strPassedString, InStr(strPassedString, Chr(13)) + 1)
intTotalRowCount = intTotalRowCount + 1
objPassedControl.Row = intTotalRowCount
'if there are more chr(13)'s in the string, loop further
'else you have the last row, determine if it is hidden or not
' if you do not you will increment the row and PassecControl.rowhidden will not be a valid check
If InStr(1, strPassedString, Chr(13)) <> 0 Then
'there are more rows, continue
Else
'has one row left, determine if it is hidden or not
If objPassedControl.RowHidden Then strPassedString = ""
Exit Do
End If
Loop
End If
Else 'there are just more chr(13)'s in the row
If Not (ArrHiddenCol(lngColCntr) And Not chkHiddenGridCols.CheckState) Then
arrExport(intRowCount, intColumnCount) = FormatString(Mid(strPassedString, 1, InStr(strPassedString, Chr(13)) - 1))
blnSomethingExported = True
End If
strPassedString = Mid(strPassedString, InStr(1, strPassedString, Chr(13)) + 1)
intRowCount = intRowCount + 1
intTotalRowCount = intTotalRowCount + 1
intTotalRowsToWrite = intTotalRowsToWrite + 1
intColumnCount = 0
lngColCntr = dblGridBeginColumn.Value
objPassedControl.Row = intTotalRowCount
'if next row is hidden and must not be exported, remove it
If Len(Trim(strPassedString)) > 0 Then
Do While objPassedControl.RowHidden And Not chkHiddenGridRows.CheckState
strPassedString = Mid(strPassedString, InStr(strPassedString, Chr(13)) + 1)
intTotalRowCount = intTotalRowCount + 1
objPassedControl.Row = intTotalRowCount
'if there are more chr(13)'s in the string, loop further
'else you have the last row, determine if it is hidden or not
' if you do not you will increment the row and objPassedControl.rowhidden will not be a valid check
If InStr(1, strPassedString, Chr(13)) <> 0 Then
'there are more rows, continue
Else
'has one row left, determine if it is hidden or not
If objPassedControl.RowHidden Then
strPassedString = ""
End If
Exit Do
End If
Loop
End If
End If
End If 'if row hidden
End If 'if there are more rows
Loop
If blnSomethingExported = True Then Call ExportGridDataToExcelSub()
If (intNumberOfRowsToExport > 0) And intTotalRowCount / intNumberOfRowsToExport * 100 <= 100 Then prgExport.Value = intTotalRowCount / intNumberOfRowsToExport * 100
'prgExport.Value = intTotalRowCount / intNumberOfRowsToExport * 100
Loop
prgExport.Value = 0
objXl.Cells.Select()
objXl.Selection.Columns.AutoFit()
objXl.Range("A" & lngStartingRow + 1).Select()
objXl.ActiveWindow.FreezePanes = True
' objXl.ActiveSheet.Range("A" & intTotalRowsToWrite + lngStartingRow + 1 & ":" & "A" & (intTotalRowsToWrite + lngStartingRow + 1) & "").Value = "Export Run By"
' objXl.ActiveSheet.Range("B" & intTotalRowsToWrite + lngStartingRow + 1 & ":" & "B" & (intTotalRowsToWrite + lngStartingRow + 1) & "").Value = objGeneral.UserName & " --> " & objGeneral.UserID
' objXl.ActiveSheet.Range("A" & intTotalRowsToWrite + lngStartingRow + 2 & ":" & "A" & (intTotalRowsToWrite + lngStartingRow + 2) & "").Value = "Export Run On"
' objXl.ActiveSheet.Range("B" & intTotalRowsToWrite + lngStartingRow + 2 & ":" & "B" & (intTotalRowsToWrite + lngStartingRow + 2) & "").Value = objGeneral.TodaysDate
objXl.Visible = True
Call objGeneral.DisplayMessage(Qm.Enum.EnumMainFormNET.enumMessageType.msgtApplicationMessage, Qm.Enum.EnumMainFormNET.enumMessageSource.msgsDataBase, 60339, Me.Handle.ToInt32, intTotalRowsToWrite.ToString)
'~~ records successfully exported.
objXl = Nothing
ErrorHandler:
If Err.Number <> 0 Then objGeneral.DisplayMessage(Qm.Enum.EnumMainFormNET.enumMessageType.msgtMessageBox, Qm.Enum.EnumMainFormNET.enumMessageSource.msgsResourceFile, 999, 0, MsgBoxStyle.Critical, "Qmuzik", Err.Number, Err.Description)
End Sub
Kind regards,