DO WHILE / UNTIL LOOP OPTIMIZATION

• lu - Si

  SSC Veteran

  Points: 262

  More actions

  June 27, 2014 at 12:53 am

  #396970

  Hi

  Can you please help me optimize my module it just takes forever to execute

  i am exporting about 20 000 records and its pretty slow

  Thanks for any tips in advance

  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

  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

  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