I have a 2-fold problem with my listbox edit sub. Userform contains 3 textboxes to add/update/delete items (3 columns) to a list box. The items in the list are stored in a sheet. I want the user to select any item from the list and update the items from the textboxes. The textboxes populate the listbox selection. The code works to populate except that 1.) when an item is selected, the actual update is applied to the last item in the row and not the user selected item from the listbox.
This translates to the delete sub as well - a user selects an item from the listbox and deletes, however the last item is deleted, not the item the user selects in the listbox. Also, when an item is deleted, the preceding data rows would need to move up to fill the deleted row. Right now, all I have is code to do this for a single range and not a row.
The second part of the problem is that when a user adds an item (the add sub is called up in a different form but uses the same sheet), the item needs to be arranged within the listbox sequentially (each item contains a unique numerical value). I don't know if it would be easier to add VBA buttons to move listbox items up or down or have VBA look at the value of the item and place it in sequential order. The less options would be better, so if VBA could look at the item's attribute and arrange it, that would be ideal.
Best regards.
Code:
[COLOR=#333333]Option Explicit[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">
Const miROW_NO__HEADER As Integer = 1
Const miCOL_NO__FM As Integer = 1
Const miCOL_NO__TVD As Integer = 2
Const miCOL_NO__MD As Integer = 3
Const msTEST_COLUMN As String = "A"
Const msSHEET_NAME As String = "Sheet1"
Dim miRowNo_Current As Integer
Dim miRowNo_Last As Integer
Private Sub UserForm_Initialize()
Const sTEST_COLUMN As String = "A"
Dim Rng As Range
Dim lastrow As Long
Dim LastCol As Long
With Sheets(msSHEET_NAME)
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range(Cells(2, 1), Cells(lastrow, 1))
' Populate controls only if the worksheet contains at least one data row
If .Range(sTEST_COLUMN & miROW_NO__HEADER).Offset(1, 0).Value <> vbNullString Then
miRowNo_Last = .Range(sTEST_COLUMN & .Rows.Count).End(xlUp).Row
miRowNo_Current = miRowNo_Last
Me.txtFm.Text = .Cells(miRowNo_Last, miCOL_NO__FM).Text
Me.txtMD.Text = .Cells(miRowNo_Last, miCOL_NO__MD).Text
Me.txtTVD.Text = .Cells(miRowNo_Last, miCOL_NO__TVD).Text
End If
End With
Set Rng = Nothing
Me.Repaint
' txtFm.SetFocus
Dim lbtarget As MSForms.ListBox
Dim rngSource As Range
Dim cLastRow As Long
Dim bLastRow As Long
bLastRow = Sheets(msSHEET_NAME).Range("A" & Rows.Count).End(xlUp).Row
' populates listbox with data
With Sheets(msSHEET_NAME)
Set rngSource = .Range("A2:C" & bLastRow)
Set lbtarget = Me.ListBox1
With lbtarget
.ColumnCount = 3
.ColumnWidths = "185;50;40"
.List = rngSource.Cells.Value
End With
End With
txtFm.SetFocus
End Sub
Private Sub ListBox1_click()
With ThisWorkbook.Sheets(msSHEET_NAME)
txtFm.Text = Me.ListBox1.List(ListBox1.ListIndex, 0)
txtMD.Text = Me.ListBox1.List(ListBox1.ListIndex, 1)
txtTVD.Text = Me.ListBox1.List(ListBox1.ListIndex, 2)
End With
End Sub
Private Sub cmdUpdate_Click()
If MsgBox("You are about to update your formation information.", vbYesNo + vbDefaultButton2, "Update Formation Record") = vbNo Then
Else
With ThisWorkbook.Sheets(msSHEET_NAME)
.Cells(miRowNo_Current, miCOL_NO__FM).Value = Me.txtFm.Text
.Cells(miRowNo_Current, miCOL_NO__MD).Value = Me.txtMD.Text
.Cells(miRowNo_Current, miCOL_NO__TVD).Value = Me.txtTVD.Text
End With
End If
UserForm_Initialize
</code>[COLOR=#333333]End Sub[/COLOR]
This translates to the delete sub as well - a user selects an item from the listbox and deletes, however the last item is deleted, not the item the user selects in the listbox. Also, when an item is deleted, the preceding data rows would need to move up to fill the deleted row. Right now, all I have is code to do this for a single range and not a row.
Code:
[COLOR=#333333]Private Sub cmdDeleteItem_Click()[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;"> Dim searchRange As Range
Dim destRange As Range
Dim foundCell As Range
Dim lastRow As Long
If Me.txtFm.Text = "" Then
Exit Sub
End If
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Set searchRange = Range("A1:A" & lastRow)
'search for it, look in values, at whole cell contents and match case of entries.
Set foundCell = searchRange.Find(cboListItems.Text, , xlValues, xlWhole, , , True)
If Not foundCell Is Nothing Then
'we found the match, now delete it
foundCell.ClearContents ' erased, but blank cell remains
'move other entries up to fill the gap
If foundCell.Row < lastRow Then
Set searchRange = Range("A" & foundCell.Row + 1 & ":A" & lastRow)
Set destRange = Range("A" & foundCell.Row & ":A" & lastRow - 1)
searchRange.Cut Destination:=destRange
Application.CutCopyMode = False
End If
'call the _Activate routine to refill the list properly
UserForm_Activate
End If
Set searchRange = Nothing
Set foundCell = Nothing </code>[COLOR=#333333]End Sub[/COLOR]
The second part of the problem is that when a user adds an item (the add sub is called up in a different form but uses the same sheet), the item needs to be arranged within the listbox sequentially (each item contains a unique numerical value). I don't know if it would be easier to add VBA buttons to move listbox items up or down or have VBA look at the value of the item and place it in sequential order. The less options would be better, so if VBA could look at the item's attribute and arrange it, that would be ideal.
Code:
[COLOR=#333333]Private Sub cmdAdd_Click()[/COLOR]
<code style="margin: 0px; padding: 0px; font-style: inherit; font-weight: inherit; line-height: 12px;">
Dim iRow As Long
With ThisWorkbook.Sheets(msSHEET_NAME)
'find first empty row in database
iRow = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
If WorksheetFunction.CountIf(.Range("A1", .Cells(iRow, 1)), Me.txtFm.Value) > 0 Then
MsgBox "That formation already exists.", vbCritical
Exit Sub
End If
'check for formation name
If Trim(Me.txtFm.Value) = "" Then
Me.txtFm.SetFocus
MsgBox "Please enter a formation name."
Exit Sub
End If
'check valid entries of text boxes
If txtMD.Value = -1 Then
MsgBox "You must enter a MD."
Exit Sub
End If
If txtTVD.Value = -1 Then
MsgBox "You must enter a TVD."
Exit Sub
End If
End With
With ThisWorkbook.Sheets(msSHEET_NAME)
miRowNo_Last = .Range(msTEST_COLUMN & .Rows.Count).End(xlUp).Row + 1
.Cells(miRowNo_Last, miCOL_NO__FM) = Me.txtFm.Text
.Cells(miRowNo_Last, miCOL_NO__MD) = Me.txtMD.Text
.Cells(miRowNo_Last, miCOL_NO__TVD) = Me.txtTVD.Text
End With
'clear the data
Me.txtFm.Value = ""
Me.txtMD.Value = ""
Me.txtTVD.Value = ""
UserForm_Initialize
End Sub
'~~> Preventing input of non numerics
Private Sub txtMD_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case vbKey0 To vbKey9, vbKeyBack, vbKeyClear, vbKeyLeft, _
vbKeyRight, vbKeyUp, vbKeyDown, vbKeyTab
Case Else
KeyAscii = 0
MsgBox "You must enter a Measured Depth (MD) in feet."
End Select
End Sub
'~~> Preventing input of non numerics
Private Sub txtTVD_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case vbKey0 To vbKey9, vbKeyBack, vbKeyClear, vbKeyLeft, _
vbKeyRight, vbKeyUp, vbKeyDown, vbKeyTab
Case Else
KeyAscii = 0
MsgBox "You must enter a Measured Depth (TVD) in feet."
End Select
</code>[COLOR=#333333]End Sub[/COLOR]
Best regards.