VBA code for list box display causing error / crash

[Lil Stinker]

Hello,
I am trying to set up a user form to add new client information as well as display the new and existing entries in a list box on the form. There are currently 22 columns / text box fields and just under 50 rows of existing entries. I'm using the following code for adding new entries and everything seems to work just fine here.

Private Sub AddNewBttn_Click()

'Validations---------------------
If Me.Project.Value = "" Then
    MsgBox "    Enter a Project Title, please.", vbCritical, "What the heck?"
    Exit Sub
End If

If Me.Customer.Value = "" Then
    MsgBox "    Enter a Customer Name, please.", vbCritical, "What the heck?"
    Exit Sub
End If

If Me.MnContact.Value = "" Then
    MsgBox "    Enter a Contact Name, please.", vbCritical, "What the heck?"
    Exit Sub
End If

'Check Dupe----------------------
Dim wk As Worksheet
Set wk = ThisWorkbook.Sheets("Client_Db")

If Application.WorksheetFunction.CountIf(wk.Range("A:A"), Me.Project.Value) > 0 Then
    MsgBox Project.Value + " already exists!", vbCritical, "What the heck?"
    Exit Sub
End If

'Add Info------------------------
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(wk.Range("A:A"))

wk.Range("A" & last_row + 1).Value = last_row
wk.Range("B" & last_row + 1).Value = Me.Project.Value
wk.Range("C" & last_row + 1).Value = Me.Customer.Value
wk.Range("D" & last_row + 1).Value = Me.Billing_1.Value
wk.Range("E" & last_row + 1).Value = Me.Billing_2.Value
wk.Range("F" & last_row + 1).Value = Me.Billing_3.Value
wk.Range("G" & last_row + 1).Value = Me.Billing_4.Value
wk.Range("H" & last_row + 1).Value = Me.Billing_5.Value
wk.Range("I" & last_row + 1).Value = Me.Shipping_1.Value
wk.Range("J" & last_row + 1).Value = Me.Shipping_2.Value
wk.Range("K" & last_row + 1).Value = Me.Shipping_3.Value
wk.Range("L" & last_row + 1).Value = Me.Shipping_4.Value
wk.Range("M" & last_row + 1).Value = Me.Shipping_5.Value
wk.Range("N" & last_row + 1).Value = Me.PhNum.Value
wk.Range("O" & last_row + 1).Value = Me.OtherNum.Value
wk.Range("P" & last_row + 1).Value = Me.MnContact.Value
wk.Range("Q" & last_row + 1).Value = Me.OtherCont.Value
wk.Range("R" & last_row + 1).Value = Me.Email.Value
wk.Range("S" & last_row + 1).Value = Me.OtherEmail.Value
wk.Range("T" & last_row + 1).Value = Me.ShpComboBox.Value
wk.Range("U" & last_row + 1).Value = Me.ShipAcct.Value
wk.Range("V" & last_row + 1).Value = Me.Notes.Value

MsgBox "Congratulations! " + Me.Project.Value + " has been added to the database.", vbInformation, "Successful Entry"

'Clear Fields--------------------------
Me.Project.Value = ""
Me.Customer.Value = ""
Me.Billing_1.Value = ""
Me.Billing_2.Value = ""
Me.Billing_3.Value = ""
Me.Billing_4.Value = ""
Me.Billing_5.Value = ""
Me.Shipping_1.Value = ""
Me.Shipping_2.Value = ""
Me.Shipping_3.Value = ""
Me.Shipping_4.Value = ""
Me.Shipping_5.Value = ""
Me.PhNum.Value = ""
Me.OtherNum.Value = ""
Me.MnContact.Value = ""
Me.OtherCont.Value = ""
Me.Email.Value = ""
Me.OtherEmail.Value = ""
Me.ShpComboBox.Value = ""
Me.ShipAcct.Value = ""
Me.Notes.Value = ""

Call Show_Clients

End Sub


Private Sub Show_Clients()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Client_Db")
Dim last_row As Integer
last_row = Application.WorksheetFunction.CountA(ws.Range("A:A"))

With Me.ListBox1
    .ColumnCount = 23
    .ColumnHeads = True
    .ColumnWidths = "40,150,150,120,120,120,120,120,120,120,120,120,120,72,72,120,120,120,120,80,72,200"
   
    If last_row = 1 Then
    .RowSource = "Client_Db!A2:V2"
    Else
    .RowSource = "Client_Db!A2:V" & last_row
    End If

End With

End Sub

The problem is the list box doesn't display anything until I add an entry. Then it shows all the entries. However, I want it to display all the entries when the user form is activated, not just after a client is added. So I tried entering Call Show_Clients under UserForm_Activate() and later under UserForm_Initialize () separately but both end up in multiple errors and Excel crashing whenever I try to add a new entry.

Error examples:
Run-time error '-2147417848 (80010108)': Method 'Value' of object 'Range' failed... give it time, Excel crashes.
Run-time error 2147417848 Automation error... click OK, Excel crashes.
Out of stack space, Excel crashes

I can't seem to figure this one out. Is there a limit to how much data can be displayed in a list box? Any suggestions would be appreciated.

 

[dmt32]

Hi,

try following updated approach & see if this will do what you want.

Make a BACKUP of your workbook and then DELETE ALL existing code in your userform

Place ALL following codes in your userform code page

Option Explicit

Dim wsClient_Db     As Worksheet
Dim last_row        As Long
Dim arr             As Variant

Private Sub AddNewBttn_Click()
    Dim RequiredEntry       As Variant
    Dim Data()              As Variant
    Dim i                   As Long
    
    ReDim Data(1 To UBound(arr))
    
    'Check Dupe Project----------------------
    If IsDuplicate(Me.Project, wsClient_Db) Then Exit Sub
    
    'required entry controls
    RequiredEntry = Application.Index(arr, 0, Array(1, 2, 15))
    
    For i = 1 To UBound(arr)
        With Me.Controls(arr(i))
            'Validations---------------------
            If Not IsError(Application.Match(arr(i), RequiredEntry, 0)) And Len(.Value) = 0 Then
                MsgBox "Enter " & arr(i) & ", please.", vbCritical, "What the heck?"
                .SetFocus
                Exit Sub
            End If

            'build data array
            Data(i) = .Value
        
        End With
    Next i
    
    'Add Info------------------------
    last_row = last_row + 1
    wsClient_Db.Cells(last_row, 1).Value = last_row
    wsClient_Db.Cells(last_row, 2).Resize(, UBound(Data)).Value = Data

    'refresh listbox
    Call Show_Clients
    
    'inform user
    MsgBox "Congratulations! " + Me.Project.Value + " has been added To the database.", vbInformation, "Successful Entry"
    
   'clear controls
   cmdClear_Click
    
End Sub

Private Sub Show_Clients()
    With Me.ListBox1
        .RowSource = ""
        .RowSource = wsClient_Db.Name & "!A2:V" & last_row
    End With
End Sub

Private Sub cmdClear_Click()
    Dim i As Long
     'clear controls
    For i = 1 To UBound(arr)
        With Me.Controls(arr(i))
            .Value = ""
            If i = 1 Then .SetFocus
            .Locked = False
         End With
    Next i
End Sub

Private Sub UserForm_Initialize()
    
    
    Set wsClient_Db = ThisWorkbook.Worksheets("Client_Db")
    last_row = Application.WorksheetFunction.CountA(wsClient_Db.Range("A:A"))
    If last_row = 1 Then last_row = 2
    
    With Me.ListBox1
        .ColumnCount = UBound(ControlsArray)
        .ColumnHeads = True
        .ColumnWidths = "40,150,150,120,120,120,120,120,120,120,120,120,120,72,72,120,120,120,120,80,72,200"
    End With
    
    Show_Clients
    arr = ControlsArray
    
End Sub

Note the variables at the top – these MUST be placed at very TOP of your userforms code page OUTSIDE any procedure



Place following codes is a STANDARD module

Option Base 1

Function IsDuplicate(ByVal Box As Object, ws As Object) As Boolean
    IsDuplicate = Len(Box.Value) > 0 And _
    Application.WorksheetFunction.CountIf(ws.Range("B:B"), Box.Value) > 0
    If IsDuplicate Then MsgBox Box.Value + " already exists!", vbCritical, "What the heck?": Box.SetFocus
End Function

Function ControlsArray()
    ControlsArray = Array("Project", "Customer", "Billing_1", "Billing_2", "Billing_3", _
                    "Billing_4", "Billing_5", "Shipping_1", "Shipping_2", "Shipping_3", _
                    "Shipping_4", "Shipping_5", "PhNum", "OtherNum", "MnContact", _
                    "OtherCont", "Email", "OtherEmail", "ShpComboBox", "ShipAcct", "Notes")
End Function

Hopefully, this approach will resolve your issue.

Dave

 

[Lil Stinker]

Thanks, Dave! Appreciate the effort! I wasn't expecting a whole code rewrite. Sorry, I'm quite green at VBA so I don't even understand a lick of what you put forth. Unfortunately, I get the same exact result with your code.

I followed everything to the letter. Wiped out all existing code for the userform and module. But it results in the same "Run-time error '-2147417848 (80010108)': Method 'Value' of object 'Range' failed". If I choose Debug, it automatically highlights "wsClient_Db.Cells(last_row, 1).Value = last_row". If I choose End or click the Stop button, Excel crashes and restarts.

I'm running Office Professional Plus 2019 if that makes any difference at all. Also, the list box is missing the last column. Would that be because the array is referring to the number of textbox fields rather than the actual number of columns on the Client_Db sheet? I have column A:V (22) on the sheet but only 21 text boxes on the form.

 

[dmt32]

I adapted code from another project I had & should work ok without any of the Issues you are having.

I suggest try repairing your installed application Repair an Office application
and see if this helps resolve.

If still have problems then helpful if can place copy of your workbook with dummy data in a file sharing site like dropbox & provide a link to it.

Dave