VBA code from Excel 2013 becomes extreme slow in Office 365

  Kiến thức lập trình

I understand that my code is way to long to post, although I don’t know an alternative.
My problem is that I have VBA-code which runs fine in Excel 2013 on a very old PC (which is broken).
If I run the code in Office365 on a new PC it becomes extremely slow.

The code reads sheets within workbooks. Within these sheets there are blocks of data which are converted to tab delimited text files.

The code is in a workbook. This workbook is containing 2 modules with code:

  1. BlockConvert
  2. cStringBuilder

I have tried to actvate libraries Microsoft ADO 2.8 and 6.0 although this make no difference.
I have tried MZ-Tools en Rubberduck although no issues found.

Any idea where i should look for the cause?

This is the code in BlockConvert:

Private BLOCK_SIZE& 'Number of columns to read in for each block
Private WB_PATH$    'the template for the full path to the workbooks
Private WB_START&   'the number of the first workbook
Private WB_END&     'the number of the last workbook
Private OUT_PATH$   'The path where output files will be stored
Private OUT_NAME$   'The name template for output files
Private bOverwrite As Boolean  'Whether or not to overwrite output files

Private pOutputRow& 'just a variable to keep track of which output row we are on. It is just for demo purposes. You can remove this when you do your own processing.
Private pFSO As FileSystemObject, pLog As TextStream

Option Explicit 'Require variable declaration (remove this if you don't like it)
Private Sub InitSetup()
    Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
    With ws
        If CBool(.Range("CFG_DEBUG").Value) Then
            Const PRJ_PATH$ = "U:UsersRichardProjectsRACExcel ADO"
            BLOCK_SIZE& = 131 'Number of columns to read in for each block
            WB_PATH$ = PRJ_PATH & "Input_WorkbooksDetailbook#.xls" 'the template for the full path to the workbooks
            WB_START& = 1 'the number of the first workbook
            WB_END& = 10 'the number of the last workbook
            OUT_PATH = PRJ_PATH & "Output"
            BLOCK_SIZE& = 131 'Number of columns to read in for each block
            WB_PATH$ = .Range("CFG_WBPath").Value
            WB_START& = .Range("CFG_WBStart").Value
            WB_END& = .Range("CFG_WBEnd").Value
            OUT_PATH = .Range("CFG_OutPath").Value
        End If
        OUT_NAME = .Range("CFG_OutName").Value
        bOverwrite = CBool(.Range("CFG_Ovrw").Value)
    End With
End Sub
Public Sub ConvertData()
    'This is the Main Routine
    Dim wb As Workbook, ws As Worksheet
    Dim nBook&, nSheet&  'Vars to keep track of workbook and worksheet numbers
    Dim sBookPath$, sSheetName$, nBlock&
    Dim arrValues() As Variant 'the array that will hold the values
    Dim bKeepGoing As Boolean
    Dim sOutPath$, sResult$, bSkip As Boolean
    'On Error GoTo HandleErr
    InitLog 'clear the debugging log
    InitSetup 'fill in setup values
    Set pFSO = New FileSystemObject 'used to determine files sizes etc.
    'the following 2 lines are Just for demo purposes.
    'You can remove this when you do your own processing.
    pOutputRow = 0
   '' Application.DisplayAlerts = False
    If Not pFSO.DriveExists(Left$(OUT_PATH, 1)) Then
      MsgBox "Please check your output path. The drive is invalid." & vbCrLf & vbCrLf & "Path:  " & OUT_PATH, vbExclamation
      Exit Sub
    End If
    If Not pFSO.FolderExists(OUT_PATH) Then pFSO.CreateFolder OUT_PATH
    For nBook = WB_START To WB_END 'Loop though all workbooks
        'Get the path to the workbook using the WB_PATH template
        sBookPath = Replace(WB_PATH, "#", nBook) 'replace the # symbol with the current book number.
        'Open an ADO reference to the workbook
        Set wb = ConnectToBook(sBookPath)
        If wb Is Nothing Then GoTo NextBook 'If adoCmd Is Nothing, An error occurred, so skip this workbook. (The error message was already shown)
        For nSheet = 1 To wb.Sheets.Count  'Loop though all worksheets
            Set ws = wb.Sheets(nSheet)
            'Get the name of the sheet
            sSheetName = ws.Name
            nBlock = 0
                nBlock = nBlock + 1
                arrValues = ReadWorkSheetBlock(ws, nBlock)
                If SafeUbound(arrValues, 1) = -1 Or SafeUbound(arrValues, 2) = -1 Then Exit Do 'the block was empty, skip to the next worksheet
                sOutPath = pFSO.BuildPath(OUT_PATH, OUT_NAME)
                sOutPath = Replace(sOutPath, "{b#}", nBook)
                sOutPath = Replace(sOutPath, "{b}", wb.Name)
                sOutPath = Replace(sOutPath, "{s#}", nSheet)
                sOutPath = Replace(sOutPath, "{s}", sSheetName)
                sOutPath = Replace(sOutPath, "{k#}", nBlock)
                bSkip = False
                If Not bOverwrite And pFSO.FileExists(sOutPath) Then
                  Dim vbAns As VbMsgBoxResult
                  vbAns = MsgBox("The following file exists. Do you want to overwrite it?" & vbCrLf & sOutPath, vbQuestion Or vbYesNoCancel Or vbDefaultButton2)
                  If vbAns = vbNo Then bSkip = True
                  If vbAns = vbCancel Then GoTo AbortConvert
                End If
                If bSkip Then
                  sResult = "SKIPPED " & sOutPath & " - The file exists and the user chose not to overwrite."
                  On Error Resume Next
                  WriteTDF arrValues, sOutPath, bOverwrite
                  If Err.Number = 0 Then
                      sResult = "Successfully converted " & sOutPath
                      sResult = "ERROR converting " & sOutPath & " - " & Err.Description
                  End If
                End If

                On Error GoTo HandleErr
                pOutputRow = pOutputRow + 1
                ThisWorkbook.ActiveSheet.Range("OUT_DATA").Cells(pOutputRow, 1).Value = sResult
        Next nSheet
        If Not wb Is Nothing Then wb.Close SaveChanges:=False
NextBook: 'a label so we can skip to the next workbook if there was an error above
    Next nBook
    'We are DONE
    Exit Sub
    ShowError "ConvertData", Err
    Exit Sub
    If Not wb Is Nothing Then wb.Close SaveChanges:=False
    ThisWorkbook.ActiveSheet.Range("OUT_DATA").Cells(pOutputRow + 1, 1).Value = "User canceled conversion process."
    ''Application.DisplayAlerts = True
    Exit Sub
End Sub

Private Function ConnectToBook(bookPath$) As Workbook
    On Error GoTo WBErr
    If pFSO.FileExists(bookPath) Then
        WriteLog "Connecting to book " & bookPath & " SIZE: " & pFSO.GetFile(bookPath).Size
        WriteLog "Book path not found: " & bookPath
    End If
    Set ConnectToBook = Application.Workbooks.Open(bookPath, False, True, addtomru:=False)
    Exit Function
    ''ShowError "ConnectToBook", Err
End Function
Private Function ReadWorkSheetBlock(ws As Worksheet, nBlockNumber&) As Variant()
    Dim nStart&, nEnd&, sRange$, rRange As Range, bHasData As Boolean
    Dim rData() As Variant, J&, sDbg$
    On Error GoTo WBErr
    sDbg = "Range1"
    nStart = 1 + (nBlockNumber - 1) * BLOCK_SIZE 'e.g.  1  for BLOCK_SIZE = 1 and nBlock = 0; 27 for nBlock = 1
    nEnd = nBlockNumber * BLOCK_SIZE  'e.g. 25  for BLOCK_SIZE = 1 and nBlock = 1; 50 for nBlock = 2
    sDbg = "Range2"
    sRange = ColLetter(nStart) & ":" & ColLetter(nEnd) 'Get the letter-format of the column number. I.e. A,B,...AA,AB...AAA,AAB... etc
    WriteLog "Reading worksheet """ & ws.Name & """.  Block=" & nBlockNumber & " Range=" & sRange
    sDbg = "Range3"
    Set rRange = ws.Range("A1").CurrentRegion.Columns(sRange)
    sDbg = "Value1"
    rData = rRange.Value2
    'Test to make sure the current block contains some data
    sDbg = "Value2"
    For J = 1 To UBound(rData, 2)
        If Not IsEmpty(rData(1, J)) Then
            bHasData = True
            Exit For
        End If
    Next J
    sDbg = "Value3"
    If bHasData Then ReadWorkSheetBlock = rData     'otherwise, return empty
    Exit Function
    ShowError "ReadWorkSheetBlock@" & sDbg, Err, False
End Function
Private Sub ShowError(sSource$, oErr As ErrObject, Optional bShow As Boolean = True)
    Dim sErr$
    sErr = "An error occurred in '" & sSource & "': " & Err.Description
    If bShow Then MsgBox sErr, vbExclamation, "VBA Error"
    WriteLog sErr
End Sub
Public Function ColLetter$(ByVal colNum&) 'determine the letter of the column
    'Get the letter-format of the column number. I.e. A,B,...AA,AB...AAA,AAB... etc
    Dim nDiv&, nLet&
    Const ascA = 65
        nDiv = (colNum - 1)  26
        nLet = colNum - nDiv * 26
        ColLetter = Chr(ascA + nLet - 1) & ColLetter
        colNum = nDiv
    Loop Until colNum = 0
End Function
Private Sub WriteLog(S$)
    pLog.WriteLine Format(Now, "hh:nn:ss") & vbTab & S
End Sub
Private Sub InitLog(Optional sName$)
    Dim sLogFile$
    If sName = "" Then sName = WBName
    Set pFSO = New FileSystemObject
    sLogFile = pFSO.BuildPath(ThisWorkbook.Path, "DEBUG_" & sName & ".txt")
    Set pLog = pFSO.OpenTextFile(sLogFile, ForWriting, True)
    WriteLog "Beginning " & sName
End Sub
Private Sub CloseLog()
End Sub
Private Function SafeUbound&(Arr As Variant, Optional Dimension& = 1)
    SafeUbound = -1 'in case of error
    On Error GoTo UboundErr
    SafeUbound = UBound(Arr, Dimension)
End Function
Private Function WriteTDF(arrValues(), sPath$, Optional bOverwrite As Boolean) As Boolean
    Const VAL_SIZE = 8
    Dim sLine$, sText$, I&, J&, bRowHasData As Boolean
    Dim nRows&, nCols&
    Dim sbLine As cStringBuilder: Set sbLine = New cStringBuilder
    Dim sbText As cStringBuilder: Set sbText = New cStringBuilder
    nRows = SafeUbound(arrValues, 1): nCols = SafeUbound(arrValues, 2)
    If nRows = -1 Or nCols = -1 Then Err.Raise vbObjectError, , "The array does not contain any data."
    'sbText.ChunkSize = (nRows * 2 + nRows * nCols * (1 + VAL_SIZE)) / 3 'set the size to assume about 8 bytes per item, plus 1 for each tab plus 2 for each line. Possibly increase twice
    For I = LBound(arrValues, 1) To nRows
        bRowHasData = False
        For J = LBound(arrValues, 2) To nCols
            If Not IsEmpty(arrValues(I, J)) Then bRowHasData = True
            If J = 1 Then
                sbLine.Append CStr(arrValues(I, J))
                sbLine.Append vbTab & arrValues(I, J)
            End If
        Next J
        If bRowHasData Then
            If I = 1 Then
                sbText.Append sbLine.ToString
                sbText.Append vbCrLf & sbLine.ToString
            End If
            sbLine.Length = 0
            Exit For 'we encountered a blank row, so quit.
        End If
    Next I
    Dim oTs As TextStream
    Set oTs = pFSO.OpenTextFile(sPath, ForWriting, True)
    oTs.Write sbText.ToString
    WriteTDF = True
End Function
Private Function WBName$()
    WBName = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1)
End Function

This is the code for cStringBuilder

Option Explicit

' Quicker insert and remove is also possible since string space does
' not have to be reallocated.

Private Const MIN_SIZE = &H4000 'the minimum buffer size (16KB, 8192 characters)

#If VBA7 Then
'Pointers to memory locations can be 32-bit or 64-bit
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDst As LongPtr, ByVal pSrc As LongPtr, ByVal ByteLen As Long)
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDst As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
#End If

Private m_Bytes() As Byte
Private m_iPos As Long
Private m_iLen As Long

Public UseExactCapacity As Boolean 'Inefficient if set to true. Used for debugging.

Public Property Get Length() As Long
   Length = m_iPos  2
End Property
Public Property Let Length(Value As Long)
   If Value > Length Then Err.Raise 9 'length can only be set LOWER than current length.
   m_iPos = Value * 2
End Property
Public Property Get Capacity() As Long
   Capacity = m_iLen  2
End Property
Public Property Let Capacity(ByVal Value As Long)
  SetCapacity Value * 2
End Property

Private Sub SetCapacity(ByVal NumBytes&)
  If NumBytes = 0 Then
    Erase m_Bytes
  ElseIf NumBytes <> m_iLen Then
    If m_iLen = 0 Then 'assume it is undimensioned or erased
      ReDim m_Bytes(NumBytes - 1)
      ReDim Preserve m_Bytes(NumBytes - 1)
    End If
  End If
  m_iLen = NumBytes
End Sub
Public Function ToString() As String
  ToString = Value
End Function

Public Property Get Value$()
   'The internal string:
   Dim sTemp$
   If m_iPos > 0 Then
      sTemp = String$(m_iPos  2, 0)
      CopyMemory StrPtr(sTemp), VarPtr(m_Bytes(0)), m_iPos
      'ToString = Left$(sTemp, m_iPos  2)
   End If
   Value = sTemp
End Property

Public Property Let Value(ByRef sThis As String)
  Dim lLen As Long
   ' Setting the string:
   lLen = LenB(sThis)
   If lLen = 0 Then
      Capacity = 0
      m_iPos = 0
      'expand string if necessary
      VerifyCapacity lLen
      CopyMemory VarPtr(m_Bytes(0)), StrPtr(sThis), lLen
      m_iPos = lLen
   End If
End Property
Private Sub VerifyCapacity(ByVal NumBytes As Long)
  If m_iLen < NumBytes Then
    If UseExactCapacity Then
      SetCapacity NumBytes
      SetCapacity NextSize(NumBytes)
    End If
  End If
End Sub
Private Function NextSize&(Num&)
  NextSize = MIN_SIZE
  Do Until NextSize >= Num
    NextSize = NextSize * 2
End Function
Public Sub Append(ByRef sAdd As String)
  Dim lLen As Long
   ' Append an item to the string:
   lLen = LenB(sAdd)
   If lLen = 0 Then Exit Sub
   VerifyCapacity lLen + m_iPos
   CopyMemory VarPtr(m_Bytes(m_iPos)), StrPtr(sAdd), lLen
   m_iPos = m_iPos + lLen
End Sub

Public Sub AppendByVal(ByVal sAdd As String)
   Append sAdd
End Sub
'iIndex is 0-based, so Insert(0,"A") inserts "A" before the first character, while Insert(1,"B") inserts "B" AFTER the first character
'Insert(Length, "C") IS valid and is the same as Append("C")
Public Sub Insert(ByVal iIndex As Long, ByRef sAdd As String)
Dim lLen As Long
Dim lPos As Long
Dim lSize As Long
   iIndex = iIndex * 2
   ' is iIndex within bounds?
   If iIndex > m_iPos Then
      Err.Raise 9
   ElseIf iIndex = m_iPos Then
      Append sAdd
      lLen = LenB(sAdd)
      If lLen = 0 Then Exit Sub
      VerifyCapacity m_iPos + lLen
      ' Move existing characters from current position
      lSize = m_iPos - iIndex
      ' moving existing data from iIndex to iIndex + lLen
      CopyMemory VarPtr(m_Bytes(iIndex + lLen)), VarPtr(m_Bytes(iIndex)), lSize
      ' Insert new characters:
      CopyMemory VarPtr(m_Bytes(iIndex)), StrPtr(sAdd), lLen
      m_iPos = m_iPos + lLen
   End If
End Sub
Public Sub InsertByVal(ByVal iIndex As Long, ByVal sAdd As String)
   Insert iIndex, sAdd
End Sub
'Index is 1-based, so Remove(1,1) removes the first character.
Public Sub Remove(ByVal iIndex As Long, ByVal lLen As Long)
Dim lSrc As Long
Dim lDst As Long
Dim lSize As Long
    iIndex = iIndex * 2 - 2 'subtract 2 because index 1 is the first character, bytes(0)
    lLen = lLen * 2

  ' is iIndex within bounds?
   If iIndex < 0 Or lLen < 0 Or iIndex + lLen > m_iPos Then
     Err.Raise 9
   ElseIf lLen = 0 Then
     Exit Sub
      ' Need to copy characters from iIndex*2 to m_iPos back by lLen chars:
      lSize = m_iPos - iIndex - lLen
      If lSize <> 0 Then
        lSrc = VarPtr(m_Bytes(iIndex + lLen))
        lDst = VarPtr(m_Bytes(iIndex))
        CopyMemory lDst, lSrc, lSize
      End If
      m_iPos = m_iPos - lLen
   End If
End Sub

'Public Function Find(ByVal sToFind As String, Optional ByVal lStartIndex As Long = 1, Optional ByVal compare As VbCompareMethod = vbTextCompare) As Long
'  Dim lInstr As Long
'   If (lStartIndex > 0) Then
'      lInstr = InStr(lStartIndex, m_sString, sToFind, compare)
'   Else
'      lInstr = InStr(m_sString, sToFind, compare)
'   End If
'   If (lInstr < m_iPos  2) Then
'      Find = lInstr
'   End If
'End Function

Public Sub TrimCapacity()
  SetCapacity m_iPos
End Sub

Private Sub Class_Initialize()
   ' The default allocation: 16384 bytes = 8192 characters.
  m_iLen = -1
  SetCapacity 0
End Sub

Private Sub Class_Terminate()
  SetCapacity 0 'erase the buffer
End Sub
Public Sub Clear()
  SetCapacity 0
  m_iPos = 0
End Sub

Thanks a lot for any ideas! Applogize for the long code.

Theme wordpress giá rẻ Theme wordpress giá rẻ Thiết kế website