Select listbox items and edit delete add in VBA

devofish

Board Regular
Joined
Dec 10, 2016
Messages
68
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.
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.
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Forum statistics

Threads
1,223,931
Messages
6,175,465
Members
452,646
Latest member
tudou

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top