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:
- BlockConvert
- 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"
Else
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
ThisWorkbook.ActiveSheet.Range("C13:C60000").Clear
'' 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
CloseLog
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
Do
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."
Else
On Error Resume Next
WriteTDF arrValues, sOutPath, bOverwrite
If Err.Number = 0 Then
sResult = "Successfully converted " & sOutPath
Else
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
Loop
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
CloseLog
Exit Sub
HandleErr:
ShowError "ConvertData", Err
CloseLog
Exit Sub
AbortConvert:
If Not wb Is Nothing Then wb.Close SaveChanges:=False
ThisWorkbook.ActiveSheet.Range("OUT_DATA").Cells(pOutputRow + 1, 1).Value = "User canceled conversion process."
CloseLog
''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
Else
WriteLog "Book path not found: " & bookPath
End If
Set ConnectToBook = Application.Workbooks.Open(bookPath, False, True, addtomru:=False)
Exit Function
WBErr:
''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
WBErr:
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
Do
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()
pLog.Close
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)
UboundErr:
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))
Else
sbLine.Append vbTab & arrValues(I, J)
End If
Next J
If bRowHasData Then
If I = 1 Then
sbText.Append sbLine.ToString
Else
sbText.Append vbCrLf & sbLine.ToString
End If
sbLine.Length = 0
Else
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
oTs.Close
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)
#Else
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)
Else
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
'Clear
Capacity = 0
m_iPos = 0
Else
'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
Else
SetCapacity NextSize(NumBytes)
End If
End If
End Sub
Private Function NextSize&(Num&)
NextSize = MIN_SIZE
Do Until NextSize >= Num
NextSize = NextSize * 2
Loop
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
Else
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
Else
' 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.