I have made a userform that allows the user to select a table and add rows to it and fill those rows with various information, all from the userform. I have run into a few problems with this.
First after adding or during adding the items (after hitting submit) excel would crash. It occurs randomly and is hard to reproduce.
Second after running the macro there is a good chance that all the cells in the workbook and every other object except the userform button will stop working, meaning you can't edit interact or even select anything. Then when I close the workbook excel crashes after saving. This is my major offender and I think causes the other problem.
What causes this freezing and why does it occur? How do I fix it? I have looked around and haven't found anything circumstantial. One post said that I should try editing the table with no formatting on it and I did that and it didn't work.
I can provide the excel workbook at a request basis via pm.
The code:
On Activate -
Public Sub UserForm_Activate()
Set cBook = ThisWorkbook
Set dsheet = cBook.Sheets("DATA")
End Sub
Help Checkbox -
Private Sub cbHelp_Click()
If Me.cbHelp.Value = True Then
Me.lbHelp.Visible = True
Else
Me.lbHelp.Visible = False
End If
End Sub
Brand combobox -
Public Sub cmbBrand_Change()
brandTableName = cmbBrand.Value
brandTableName = CleanBrandTableName(brandTableName)
'if brand_edit is not = to a table name then error is thrown
On Error Resume Next
If Err = 380 Then
Exit Sub
Else
cmbItemID.RowSource = brandTableName
End If
On Error GoTo 0
'Set cmbItemID's text to nothing after changing to a new brand
cmbItemID.Text = ""
End Sub
CleanBrandTableName(brandTableName) function -
Option Explicit
Public Function CleanBrandTableName(ByVal brandTableName As String) As String
Dim s As Integer
Dim cleanResult As String
For s = 1 To Len(brandTableName)
Select Case Asc(Mid(brandTableName, s, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122:
cleanResult = cleanResult & Mid(brandTableName, s, 1)
Case 95
cleanResult = cleanResult & " "
Case 38
cleanResult = cleanResult & "and"
End Select
Next s
CleanBrandTableName = Replace(WorksheetFunction.Trim(cleanResult), " ", "_")
End Function
Public Function CleanSpecHyperlink(ByVal specLink As String) As String
Dim cleanLink As Variant
cleanLink = specLink
cleanLink = Replace(cleanLink, "=HYPERLINK(", "")
cleanLink = Replace(cleanLink, ")", "")
cleanLink = Replace(cleanLink, ",", "")
cleanLink = Replace(cleanLink, """", "")
cleanLink = Replace(cleanLink, "Specs", "")
CleanSpecHyperlink = cleanLink
End Function
Browse button -
Public Sub cbBrowse_Click()
Dim rPos As Long
Dim lPos As Long
Dim dPos As Long
specLinkFileName = bFile
rPos = InStrRev(specLinkFileName, "\PDFS\")
lPos = Len(specLinkFileName)
dPos = lPos - rPos
specLinkFileName = Right(specLinkFileName, dPos)
Me.tbSpecLink.Text = specLinkFileName
End Sub
bFile function -
Option Explicit
Public Function bFile() As String
bFile = Application.GetOpenFilename(Title:="Please choose a file to open")
If bFile = "" Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
Exit Function
End If
End Function
Preview button -
Private Sub cbSpecs_Click()
If specLinkFileName = "" Then Exit Sub
cBook.FollowHyperlink (specLinkFileName)
End Sub
Add Item button -
Private Sub cbAddItem_Click()
Dim brand As String
Dim description As String
Dim listPrice As Currency
Dim cost As Currency
Dim Notes As String
Dim other As Variant
itemID = Me.tbNewItem.Text
brand = Me.tbBrandName.Text
description = Me.tbDescription.Text
specLink = Replace(specLinkFileName, specLinkFileName, "=HYPERLINK(""" & specLinkFileName & """,""Specs"")")
If Me.tbListPrice.Text = "" Then
listPrice = 0
Else
listPrice = Me.tbListPrice.Text
End If
If Me.tbCost.Text = "" Then
cost = 0
Else
cost = Me.tbCost.Text
End If
Notes = Me.tbNotes.Text
other = Me.tbOther.Text
If Me.lbItemList.listCount = 0 Then
x = 0
End If
With Me.lbItemList
Me.lbItemList.ColumnCount = 8
.AddItem
.List(x, 0) = itemID
.List(x, 1) = brand
.List(x, 2) = description
.List(x, 3) = specLink
.List(x, 4) = listPrice
.List(x, 5) = cost
.List(x, 6) = Notes
.List(x, 7) = other
x = x + 1
End With
End Sub
Submit button -
Private Sub cbSubmit_Click()
Dim n As Long
Dim v As Long
Dim vTable() As Variant
Dim r As Long
Dim o As Long
Dim c As Long
Dim w As Variant
Set brandTable = dsheet.ListObjects(brandTableName)
o = 1
listAmount = lbItemList.listCount
v = brandTable.ListRows.Count
w = 0
For c = 1 To listAmount
If brandTable.ListRows(v).Range(, 1).Value <> "" Then
brandTable.ListRows.Add alwaysinsert:=True
brandTable.ListRows.Add alwaysinsert:=True
Else
brandTable.ListRows.Add alwaysinsert:=True
End If
Next
ReDim vTable(1000, 1 To 10)
For n = 0 To listAmount - 1
vTable(n + 1, 1) = lbItemList.List(n, 0)
vTable(n + 1, 2) = lbItemList.List(n, 1)
vTable(n + 1, 3) = lbItemList.List(n, 2)
vTable(n + 1, 5) = lbItemList.List(n, 4)
vTable(n + 1, 6) = lbItemList.List(n, 5)
vTable(n + 1, 7) = lbItemList.List(n, 6)
vTable(n + 1, 8) = lbItemList.List(n, 7)
If lbItemList.List(n, 3) = "" Then
ElseIf lbItemList.List(n, 3) <> "" Then
vTable(n + 1, 4) = lbItemList.List(n, 3)
End If
If n = 0 And brandTable.DataBodyRange(1, 1) <> "" Then
For r = 1 To brandTable.ListRows.Count
If brandTable.DataBodyRange(r, 1) <> "" Then
o = r + 1
' brandTable.ListRows.Add alwaysinsert:=True
End If
Next
End If
brandTable.ListColumns(1).DataBodyRange(n + o).Value = vTable(n + 1, 1)
brandTable.ListColumns(2).DataBodyRange(n + o).Value = vTable(n + 1, 2)
brandTable.ListColumns(3).DataBodyRange(n + o).Value = vTable(n + 1, 3)
brandTable.ListColumns(4).DataBodyRange(n + o).Value = vTable(n + 1, 4)
brandTable.ListColumns(5).DataBodyRange(n + o).Value = vTable(n + 1, 5)
brandTable.ListColumns(6).DataBodyRange(n + o).Value = vTable(n + 1, 6)
brandTable.ListColumns(7).DataBodyRange(n + o).Value = vTable(n + 1, 7)
brandTable.ListColumns(8).DataBodyRange(n + o).Value = vTable(n + 1, 8)
Next
brandTable.DataBodyRange.Select
Selection.Font.Bold = True
Selection.WrapText = True
brandTable.ListColumns(5).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
brandTable.ListColumns(6).DataBodyRange.Select
Selection.NumberFormat = "$#,##0.00"
Unload Me
End Sub
Remove Items button -
Private Sub cbRemoveItems_Click()
Dim intCount As Long
For intCount = lbItemList.listCount - 1 To 0 Step -1
If lbItemList.Selected(intCount) Then
lbItemList.RemoveItem (intCount)
x = x - 1
End If
Next intCount
End Sub
There is other code that does things for the other tabs but they don't interact with this tabs code.
