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

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! :)