Class to update a userform with an external workbook and vice versa

Question

Everything is working fine; it just works too slowly. Specially, when there are 3 workbooks that a single Userform needs to open and update 3 ListBoxes.

Here I have a class that I use to:

1. Open a Workbook (as read-only), copy its contents into an array.

• I pass this array to a ListBox, so the user can see what is the content of that Workbook.
• The user can now choose what record/s he/she wants to update.

2. With the help of a Column named Trans_no, where there are unique numbers. I update the the that entirerow (depending on the number of Controls associated to each Column.)

• Given the Trans_no, I can locate the cell/row that needs updating (using sub LOOK_FOR), or the cell below the last non-blank cell in Trans_no Column.
• I loop through the collection of controls with sub PASS_THIS.

3. Delete the record, depending on the selected Trans_No.

Here is a sample userform:

Here is the code for class cls_Connection:

Private sCon As String '// Connection string
Private eApp As Excel.Application '// New instance of Excel Application
Private eWB As Excel.Workbook '// The workbook in Excel Application
Private eWS As Worksheet '// The worksheet in Excel Workbook
Private bRonly As Boolean '// Is the workbook ReadOnly?
Private bOpen As Boolean '// Is the connection open?
Private vDa() As Variant '// The data from the worksheet
Private LastMod As Date '// The time when the last change took place
Property Get timeLastModified() As Date '// this property doesnt have
 timeLastModified = LastMod '// a let proerty. so the user
End Property '// wont be able to change its value
Property Get isReadOnly() As Boolean '// This property doesn't have
 isReadOnly = bRonly '// a let property. so the user
End Property '// wont be able to change its value
Property Let ConnectionString(ByVal FilePath As String)
 sCon = FilePath '// This property sets the connection
End Property '// string.
Property Get ConnectionString() As String
 ConnectionString = sCon '// This property shows the connection
End Property '// string.
Property Get Data() As Variant '// There is only get data property.
 Data = vDa() '// So the user won't be able to
End Property '// set/change its value.
Private Sub OpenConnection(ByRef sPass As String, Optional ByRef bRead As Boolean = False)
 Set eApp = New Excel.Application '// Creating new instance of excel
 On Error GoTo ErrHandler '// basic error handler
 Set eWB = eApp.Workbooks.Open(sCon, , bRead, , sPass, , True)
 Set eWS = eWB.Sheets(1) '// sets new worksheet
 bOpen = True '// is it open?
 bRonly = eWB.ReadOnly '// is it opened as readonly?
 LastMod = eWB.BuiltinDocumentProperties("Last Save Time")
 Exit Sub '// exits the sub after updating last mod
ErrHandler:
 MsgBox Err.Description, vbCritical, Err.Number & " - Call a programmer!"
 End
End Sub
Private Sub CloseConnection(ByRef bChanges As Boolean)
 On Error GoTo ErrHandler '// basic error handling
 If Not bRonly Then
 eWB.Save
 LastMod = eWB.BuiltinDocumentProperties("Last Save Time")
 End If
 eWB.Close bChanges '// Closes the workbook and save it as needed.
 eApp.Quit '// Quits the new instance of Excel.
 bOpen = False '// changes the global boolean
 Exit Sub '// exits the sub
ErrHandler:
 MsgBox Err.Description, vbCritical, Err.Number & " - Call a programmer!"
End Sub
Public Sub UpdateMe(ByRef Password As String)
 OpenConnection Password, True '// Opens the workbook.(readonly)
 If eWS Is Nothing Then Exit Sub '// Exit if there is no worksheet.
 Update '\\ calls the update routine
 CloseConnection False '// Closes the workbook.
End Sub
Private Sub Update()
 If Not bOpen Then Exit Sub '// checks if there is an open wb
 Erase vDa() '// clears the database
 With eWS '// updates it by getting the last row+cols
 vDa() = .Range(.Cells(1, 1), .Cells(GET_LAST(Row, .Cells), .Cells.End(xlToRight).Column))
 End With
End Sub
Public Sub UpdateRecords _
 (ByVal Password As String, ByVal whatToDo As xlAddNewEditDelete, _
 Optional ByVal transNo As String, Optional ByRef cControls As Collection)
 Dim strMsg As String
 Dim rActive As Range
 If CanWeProceed(sCon) Then '\\ calls the canweproceed FUNCTION
 
 If Not whatToDo = AddNew Then '// basic checking if arguements
 If Len(Trim(transNo)) = 0 Then Exit Sub ' for addnew records are
 End If '// present
 If Not whatToDo = Delete Then '// basic checking if arguements
 If cControls Is Nothing Then Exit Sub '// for delete records are
 End If '// present
 
 OpenConnection Password, False '\\ opens the workbook that will be updated
 If bRonly Then GoTo FileOpen '// do not proceed if opened as readonly
 
 Select Case whatToDo '// select case depending on what the
 Case AddNew '// in case the user want to add new records
 Set rActive = eWS.Cells(GET_LAST(Row, eWS.Range("A:A")) + 1, 1)
 PASS_THIS cControls, rActive '// after locating the lastrow, pass the data
 Case Edit '// in case the user want to edit
 Set rActive = LOOK_FOR(transNo) '// locate the trans# then update
 If Not rActive Is Nothing Then PASS_THIS cControls, rActive
 Case Delete '// in case the user want to delete
 Set rActive = LOOK_FOR(transNo) '// locate the trans# then delete
 If Not rActive Is Nothing Then rActive.EntireRow.Delete shift:=xlUp
 End Select
 Update '\\ calls the update routine
 CloseConnection True '\\ closes the workbook and save the changes
 End If
 
 Exit Sub
 
FileOpen:
 MsgBox "Request denied! Encountered a critical error!" & vbCrLf & _
 "Do not close this error message.", vbCritical, " Call a programmer!"
End Sub
Private Sub PASS_THIS(ByRef cControls As Collection, ByVal rWhere As Range)
 Dim int1 As Integer '// this sub takes a range object for update
 With cControls '// of controls and passes it to the database
 For int1 = 1 To .Count '// loops through the control.
 rWhere.Offset(, int1 - 1).value = .Item(int1).value
 Next '// pass each value to the worksheet
 End With
End Sub
Private Function LOOK_FOR(ByRef strTrans As String) As Range
 Dim bFound As Boolean '// this sub returns a range object
 Dim loop1 As Long '// if there is a valid transaction
 Dim rEach As Range '// number present in the database
 Set LOOK_FOR = eWS.Cells(GET_LAST(Row, eWS.Range("A:A")) + 1, 1)
 With eWS '// the default range is the last row
 For loop1 = 2 To .UsedRange.rows.Count + 1
 Set rEach = .Cells(loop1, 1) '// loops through the used range
 If rEach.value = strTrans Then '// and check each transaction #
 Set LOOK_FOR = rEach '// if there is an equivalent,
 Exit Function '// return that range and exit function.
 End If '// if the trans# to be updated is not
 Next '// found, this will give the last row
 End With '// and put the data in that row.
End Function
Private Function CanWeProceed(FilePath As String) As Boolean
 Dim FileNo As Integer, ErrNo As Integer
 On Error Resume Next '// Skips one error.
 FileNo = FreeFile() '// Gets an available file number.
 Open FilePath For Input Lock Read As #FileNo
 Close FileNo '// Closes the file.
 ErrNo = Err '// Resumes error handling.
 On Error GoTo 0 '// Resumes error handling.
 CanWeProceed = ErrNo = 0
End Function

Here is the code for class cls_NewRecords:

This class represents the entirety of the Userform.

Public WithEvents ContentBox As MSForms.ListBox '// Listbox containing the data
Public WithEvents FilterButton As MSForms.CommandButton '// Start to look for.
Public WithEvents FilterColumn As MSForms.ComboBox '// Where to look for.
Public FilterBox As MSForms.TextBox '// What to look for.
Public WithEvents buttonSave As MSForms.CommandButton '// Save button.
Public WithEvents buttonDelete As MSForms.CommandButton '// Delete button.
Public WithEvents buttonClear As MSForms.CommandButton '// Edit button.
Public WithEvents buttonRefresh As MSForms.CommandButton '// Edit button.
Private ControlCollection As Collection
Private vDatabase() As Variant
'Private vDetails() As Variant '// what is this for?
Private vHeaders() As Variant
Private ColumnOfEmpNumber As Integer
Private ColumnToFilter As Integer
Private DisableEvents As Boolean
Private DatabaseConnection As cls_Connection
Private ConnectionString As String
Private ExcelPassword As String
Private ColumnWidths As String
Private DatabaseLastMod As Date
Private Const MsgBoxHeader As String = "Masterlist"
Property Set Controls(ByVal cols As Collection)
 Set ControlCollection = cols
End Property
Public Sub InitializeConnection(ByVal strCon As String, ByVal strPass As String)
 ConnectionString = strCon
 ExcelPassword = strPass
 Set DatabaseConnection = New cls_Connection
 
 With DatabaseConnection
 .ConnectionString = ThisWorkbook.Path & "\" & ConnectionString
 .UpdateMe ExcelPassword
 vDatabase() = .Data
 End With
End Sub
Public Sub InitializeListBox(Optional ByVal strWidths As Variant)
 ColumnWidths = strWidths
 With ContentBox
 RefreshList
 If Not IsMissing(strWidths) Then .ColumnWidths = strWidths
 .ColumnCount = UBound(vDatabase(), 2) + 1
 End With
 vHeaders() = TRANSPOSEARR(vDatabase())
 ReDim Preserve vHeaders(LBound(vHeaders(), 1) To UBound(vHeaders(), 1), 1 To 1)
 FilterColumn.List() = vHeaders()
 TrackingDetails AddNew
End Sub
Private Sub RefreshList()
 With DatabaseConnection
 vDatabase() = .Data
 ContentBox.List() = vDatabase()
 DatabaseLastMod = .timeLastModified
 End With
End Sub
Private Sub ClearList()
 Dim int1 As Integer
 With ControlCollection
 For int1 = 1 To .Count
 If TypeName(.Item(int1)) = "ComboBox" Then
 .Item(int1).ListIndex = 0
 Else
 .Item(int1) = ""
 End If
 Next
 End With
 ContentBox.Locked = False
End Sub
Private Sub ButtonClear_Click()
 RefreshList
 ClearList
 TrackingDetails AddNew
End Sub
Private Sub ButtonRefresh_Click()
 With DatabaseConnection
 .UpdateMe ExcelPassword
 RefreshList
 End With
End Sub
Private Sub ButtonDelete_Click()
 Dim strMsg As String
 strMsg = "The database is not updated." & vbCrLf & _
 "Would you like to refresh your database?"
 ManageRecords Delete, ControlCollection.Item(1), ControlCollection, strMsg
End Sub
Private Sub ButtonSave_Click()
 Dim strMsg As String
 strMsg = "You are about to add/update a record." & vbCrLf & _
 "Are you sure you want to proceed?"
 With ControlCollection
 On Error GoTo EarlyExit
 If CDbl(.Item(1).value) > vDatabase(UBound(vDatabase(), 1), 1) Then
 ManageRecords AddNew, .Item(1), ControlCollection, strMsg
 Else
 TrackingDetails Edit
 ManageRecords Edit, .Item(1), ControlCollection, strMsg
 End If
 End With
 Exit Sub
EarlyExit:
 If Err.Number = 13 Then
 MsgBox "You are trying to save an invalid transaction number", vbInformation, Err.Number & " - Select a valid record."
 Else
 MsgBox Err.Description, vbCritical, Err.Number & " - Call a programmer!"
 End If
End Sub
Private Sub ContentBox_Click()
 Dim i1 As Integer, a() As Variant, strTrans As String
 With ContentBox
 If .ListIndex < 1 Then Exit Sub
 strTrans = .List(.ListIndex, LBound(.List(), 2))
 a() = CLEANARR(vDatabase(), strTrans, 1, False, True, True)
 End With
 With ControlCollection
 For i1 = 1 To .Count
 .Item(i1).value = a(2, i1)
 Next
 End With
End Sub
Private Sub FilterColumn_Change()
 Dim sTemp As String, i As Integer, a() As Variant
 sTemp = FilterColumn.value
 If Len(Trim(FilterColumn.value)) = 0 Then Exit Sub
 For i = LBound(vHeaders(), 1) To UBound(vHeaders(), 1)
 If sTemp = vHeaders(i, 1) Then ColumnToFilter = i
 Next
End Sub
Private Sub FilterButton_Click()
 If ContentBox.Locked Then Exit Sub
 Dim a() As Variant, sTemp As String
 sTemp = CStr(FilterBox.value)
 If Len(Trim(sTemp)) = 0 Then
 ContentBox.List() = vDatabase()
 Exit Sub
 Else
 OPTIMIZE_VBA True
 a() = CLEANARR(vDatabase, sTemp, ColumnToFilter, False, False, True)
 ContentBox.List = a()
 OPTIMIZE_VBA False
 End If
End Sub
Private Sub ManageRecords(ByVal whatToDo As xlAddNewEditDelete, _
ByRef transNo As String, ByRef colsControl As Collection, strMsg As String)
 Dim iRefresh As Byte, iProceed As Byte
 If Not isDatabaseLatest Then
 iRefresh = MsgBox("The database is not updated." & vbCrLf & _
 "Would you like to refresh your database?", _
 vbInformation + vbOKCancel, MsgBoxHeader)
 If iRefresh = 1 Then ButtonRefresh_Click
 End If
 iProceed = MsgBox(strMsg, vbInformation + vbOKCancel, MsgBoxHeader)
 If iProceed = 1 Then
 OPTIMIZE_VBA True
 DatabaseConnection.UpdateRecords ExcelPassword, whatToDo, ControlCollection.Item(1), ControlCollection
 ButtonClear_Click
 OPTIMIZE_VBA False
 End If
End Sub
Private Sub TrackingDetails(ByRef whatToDo As xlAddNewEditDelete)
 With ControlCollection
 If whatToDo = AddNew Then .Item(1).value = GiveMax(vDatabase()) + 1
 .Item(2).value = Now()
 End With
End Sub
Private Function isDatabaseLatest() As Boolean
 isDatabaseLatest = Not (CDate(FileDateTime(ThisWorkbook.Path & "\" & ConnectionString)) < DatabaseLastMod)
End Function
Private Function GiveMax(v() As Variant) As Long
Dim i As Long, H As Long
On Error Resume Next
 For i = LBound(v(), 1) To UBound(v(), 1)
 If v(i, 1) > H Then H = v(i, 1)
 Next
GiveMax = H
End Function

Here is the code for the Userform:

On initilize of the userform I create a variable as cls_NewRecords, set its properties and controls, then add them to a global collection.

Private CollectionOfClasses As Collection
Private Sub UserForm_Initialize()
Dim colControl As Collection
Dim int1 As Integer
Dim ThisUserform As cls_NewRecords
Dim ThisHelper As cls_RecordHelper
Dim limitFormat As cls_FormattedControls
Set ThisUserform = New cls_NewRecords '<~ set this variable a new class
Set CollectionOfClasses = New Collection '<~ define the public collection as new collection
Set colControl = New Collection 'collection of controls. their index refers to what column they will be placed.
For int1 = 1 To 20
 colControl.Add Me.Controls("Col" & int1), "TextBox" & int1
Next
With ThisUserform
 Set .ContentBox = listFilter '<~ the listbox that represents the workbook
 Set .FilterBox = textFilter '<~ 'text' we use to filter the workbook
 Set .FilterColumn = selectFilter '<~ ComboBox that the user chooses what column should the 'text' looked for
 Set .FilterButton = buttonFilter '<~ start looking for 'text' in the chosen column
 Set .buttonSave = buttonSave '<~ save changes ( new record/edit record)
 Set .buttonClear = buttonClear '<~ clear the userform.
 Set .buttonDelete = buttonDelete '<~ delete the record.
 Set .buttonRefresh = buttonRefresh '<~ refresh the list. (if there are changes done by other user)
 Set .Controls = colControl
 .InitializeConnection "data\att.xlsx", G.Cells(1, 1).Value '<~ sheet 'G' range 'A1' is where the password for the workbook is stored.
 .InitializeListBox "0;0;0;0;30;110;50;30;65;100;0;0;0;0;0;0;0;0;0;0;0;0" '<~ to hide unnecessary columns.
End With
CollectionOfClasses.Add ThisUserform '<~ adds this class to the collection
Set ThisUserform = Nothing '<~ minor cleanup
Set colControl = Nothing '<~ minor cleanup
With Col9
 .AddItem "Whole Day"
 .AddItem "Half Day"
 .AddItem "Under Time"
 .AddItem "Late"
 .AddItem "Suspension"
End With
selectFilter.ListIndex = 5
With Col4
.AddItem "Direct"
.AddItem "NonDirect"
.ListIndex = 0
End With
End Sub

The following function/sub are located in a regular module.

This is the OPTIMIZE_VBA Sub:

Public Sub OPTIMIZE_VBA(ByVal isOn As Boolean)
Dim bHolder As Boolean
bHolder = Not isOn
With Application
 .DisplayAlerts = bHolder
 .ScreenUpdating = bHolder
 .EnableEvents = bHolder
 .Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
 .Calculate
 If .Version > 12 Then .PrintCommunication = bHolder
End With
End Sub

This is the GET_LAST Function:

Public Function GET_LAST(c As Choice, rng As Range)
Dim o As XlSearchOrder
Dim r As Range
 o = xlByRows '<~~ default value
 If c = 2 Then o = xlByColumns '<~~ change it if looking for column
 Set r = rng.Find(What:="*", after:=rng.Cells(1), LookIn:=xlFormulas, _
 LookAt:=xlPart, SearchOrder:=o, SearchDirection:=xlPrevious, _
 MatchCase:=False)
 If r Is Nothing Then Set r = rng.Cells(1, 1) '<~~ if we found nothing give "A1"
 If c = Row Then GET_LAST = r.Row
 If c = Column Then GET_LAST = r.Column
 If c = Cell Then GET_LAST = rng.Parent.Cells(GET_LAST(Row, rng), GET_LAST(Column, rng)).Address(0, 0)
End Function

This is the CLEANARR Function:

That receives a 2D array and loops from lbound upto ubound of 1stD.

Filters the array with the given column number and criteria ('s' as string).

Public Function CLEANARR _
 (ByRef v() As Variant, ByVal s As String, ByVal c As Integer, _
 Optional ByVal RemoveMatch As Boolean = False, _
 Optional ByVal ExactMatch As Boolean = False, _
 Optional ByVal KeepHeader As Boolean = True) _
As Variant
 
Dim a(), r As Long, i1 As Long, i2 As Long
Dim StartofLoop As Integer, deleteRecord As Boolean
ReDim a(LBound(v(), 1) To UBound(v(), 1), LBound(v(), 2) To UBound(v(), 2))
StartofLoop = LBound(v(), 1)
If KeepHeader Then Call GIVE_HEADER(a(), r, StartofLoop, v())
For i1 = StartofLoop To UBound(v(), 1)
 If ExactMatch Then
 If Not (UCase(Format(v(i1, c), "0")) = UCase(Format(s, "0"))) = RemoveMatch Then deleteRecord = True
 Else
 If Not InStr(1, v(i1, c), s, vbTextCompare) = RemoveMatch Then deleteRecord = True
 End If
 
 If deleteRecord Then
 r = r + 1
 For i2 = LBound(v(), 2) To UBound(v(), 2)
 a(r, i2) = v(i1, i2)
 Next
 deleteRecord = False
 End If
Next
CLEANARR = REDUCEARR(a())
End Function

This is the TRANSPOSEARR Function:

Public Function TRANSPOSEARR(ByRef v() As Variant) As Variant
Dim rows, cols As Long
Dim s() As Variant
ReDim s(LBound(v(), 2) To UBound(v(), 2), LBound(v(), 1) To UBound(v(), 1))
For rows = LBound(v(), 1) To UBound(v(), 1)
 For cols = LBound(v(), 2) To UBound(v(), 2)
 s(cols, rows) = v(rows, cols)
 Next
Next
TRANSPOSEARR = s()
End Function

• Máté Juhász: Where it is too slow? Please debug it and try to find the part making it slow. We can't do it and it's essential to know in order to really help you making it faster.
• Romcel Geluz: The load time when calling/initializing the cls_Connection once is barely noticeable. But when calling it thrice or more (I do this when the Userform needs to work with multiple worksheet) takes too much load time. As of now I am considering to change my code into DOA/ADO based.

Answer 1

Here are some ideas about the code. However, only one of them will increase the productivity. The rest are simply there, because they are considered good practice.

Do not use End

Do not use Integer https://stackoverflow.com/questions/26409117/why-use-integer-instead-of-long

Do not even think about using Byte

Name the Columns a bit more descriptive than Col9

In the line Dim rows , cols As Long rows is Variant, not long. That is not C++. Declare it like this: Dim rows as long, cols As Long

Declare constants like this: Private Const MSG_BOX_HEADER As String = "Masterlist"

These are my 5 cents in your project. Cheers! :)