The following userform allows the user to add, delete or edit data from an userform. It has a search-function to search for entries.
However, I don't need the search-function but like the userform to list all available entries in the listbox, but let the user still allow to edit the entries when selected.
any ideas?
The sheet can be downloaded from here
However, I don't need the search-function but like the userform to list all available entries in the listbox, but let the user still allow to edit the entries when selected.
any ideas?
The sheet can be downloaded from here
Code:
'---------------------------------------------------------------------------------------
' Module : Database Form
' DateTime : 31/08/2005 10:55. Updatede 08-02-08
' Author : Roy Cox
' Purpose : Data entry form for Excel, with Search facility
'---------------------------------------------------------------------------------------
Dim MyData As Range
Dim c As Range
Dim rFound As Range
Dim r As Long
Dim rng As Range
Const frmMax As Long = 320
Const frmHt As Long = 210
Const frmWidth As Long = 280
Dim sFileName As String 'image name
Dim oCtrl As MSForms.Control
Private Sub cmbAdd_Click()
'next empty cell in column A
Set c = Range("a65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'write userform entries to database
With Me
c.Value = .TextBox1.Value
c.Offset(0, 1).Value = .TextBox2.Value
c.Offset(0, 2).Value = .TextBox3.Value
c.Offset(0, 3).Value = .TextBox4.Value
If Me.optYes Then
c.Offset(0, 4).Value = "Yes"
ElseIf .optNo Then
c.Offset(0, 4).Value = "No"
End If
'clear the form
ClearControls
End With
Application.ScreenUpdating = True
End Sub
Private Sub cmbDelete_Click()
Dim msgResponse As String 'confirm delete
Application.ScreenUpdating = False
'get user confirmation
msgResponse = MsgBox("This will delete the selected record. Continue?", _
vbCritical + vbYesNo, "Delete Entry")
Select Case msgResponse 'action dependent on response
Case vbYes
'c has been selected by Find button
Set c = ActiveCell
c.EntireRow.Delete 'remove entry by deleting row
'restore form settings
With Me
.cmbAmend.Enabled = False 'prevent accidental use
.cmbDelete.Enabled = False 'prevent accidental use
.cmbAdd.Enabled = True 'restore use
'clear form
ClearControls
End With
Case vbNo
Exit Sub 'cancelled
End Select
Application.ScreenUpdating = True
End Sub
Private Sub cmbFind_Click()
Dim strFind As String 'what to find
Dim FirstAddress As String
Dim rSearch As Range 'range to search
Set rSearch = Sheet1.Range("a6", Range("a65536").End(xlUp))
Dim f As Integer
imgFolder = ThisWorkbook.Path & Application.PathSeparator & "images" & Application.PathSeparator
strFind = Me.TextBox1.Value 'what to look for
With rSearch
Set c = .Find(strFind, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
c.Select
With Me 'load entry to form
.TextBox2.Value = c.Offset(0, 1).Value
.TextBox3.Value = c.Offset(0, 2).Value
.TextBox4.Value = c.Offset(0, 3).Value
.cmbAmend.Enabled = True 'allow amendment or
.cmbDelete.Enabled = True 'allow record deletion
.cmbAdd.Enabled = False 'don't want to duplicate record
If c.Offset(0, 4).Value = "Yes" Then .optYes = True
If c.Offset(0, 4).Value = "No" Then .optYes = True
f = 0
End With
FirstAddress = c.Address
Do
f = f + 1 'count number of matching records
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
If f > 1 Then
Select Case MsgBox("There are " & f & " instances of " & strFind, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries")
Case vbOK
FindAll
Case vbCancel
'do nothing
End Select
Me.Height = frmMax
End If
Else: MsgBox strFind & " not listed" 'search failed
End If
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("A8").AutoFilter
End Sub
Private Sub cmbAmend_Click()
Application.ScreenUpdating = False
If rng Is Nothing Then GoTo skip
For Each c In rng
If r = 0 Then c.Select
r = r - 1
Next c
skip:
Set c = ActiveCell
c.Value = Me.TextBox1.Value ' write amendments to database
c.Offset(0, 1).Value = Me.TextBox2.Value
c.Offset(0, 2).Value = Me.TextBox3.Value
c.Offset(0, 3).Value = Me.TextBox4.Value
If Me.optYes Then
c.Offset(0, 4).Value = "Yes"
ElseIf Me.optNo Then
c.Offset(0, 4).Value = "No"
End If
'restore Form
With Me
.cmbAmend.Enabled = False
.cmbDelete.Enabled = False
.cmbAdd.Enabled = True
ClearControls
.Height = frmHt
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("A8").AutoFilter
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Sub FindAll()
Dim strFind As String 'what to find
Dim rFilter As Range 'range to search
Set rFilter = Sheet1.Range("a8", Range("d65536").End(xlUp))
Set rng = Sheet1.Range("a7", Range("a65536").End(xlUp))
strFind = Me.TextBox1.Value
With Sheet1
If Not .AutoFilterMode Then .Range("A8").AutoFilter
rFilter.AutoFilter Field:=1, Criteria1:=strFind
Set rng = rng.Cells.SpecialCells(xlCellTypeVisible)
Me.ListBox1.Clear
For Each c In rng
With Me.ListBox1
.AddItem c.Value
.List(.ListCount - 1, 1) = c.Offset(0, 1).Value
.List(.ListCount - 1, 2) = c.Offset(0, 2).Value
.List(.ListCount - 1, 3) = c.Offset(0, 3).Value
.List(.ListCount - 1, 4) = c.Offset(0, 4).Value
End With
Next c
End With
End Sub
Private Sub cmbLast_Click()
Dim LastCl As Range
Set LastCl = Range("a65536").End(xlUp) 'last used cell in column A
With Me
.cmbAmend.Enabled = False
.cmbDelete.Enabled = False
.cmbAdd.Enabled = True
.TextBox1.Value = LastCl.Value
.TextBox2.Value = LastCl.Offset(0, 1).Value
.TextBox3.Value = LastCl.Offset(0, 2).Value
.TextBox4.Value = LastCl.Offset(0, 3).Value
sFileName = LastCl.Offset(0, 4).Value
End With
End Sub
Private Sub cmnbFirst_Click()
Dim FirstCl As Range
'first data Entry
Set FirstCl = Range("a1").End(xlDown).Offset(1, 0) 'allow for rows being added deleted above header row
With Me
.cmbAmend.Enabled = False
.cmbDelete.Enabled = False
.cmbAdd.Enabled = True
.TextBox1.Value = FirstCl.Value
.TextBox2.Value = FirstCl.Offset(0, 1).Value
.TextBox3.Value = FirstCl.Offset(0, 2).Value
.TextBox4.Value = FirstCl.Offset(0, 3).Value
End With
End Sub
Private Sub ListBox1_Click()
If Me.ListBox1.ListIndex = -1 Then 'not selected
MsgBox " No selection made"
ElseIf Me.ListBox1.ListIndex >= 1 Then 'User has selected
r = Me.ListBox1.ListIndex
With Me
.TextBox1.Value = ListBox1.List(r, 0)
.TextBox2.Value = ListBox1.List(r, 1)
.TextBox3.Value = ListBox1.List(r, 2)
.TextBox4.Value = ListBox1.List(r, 3)
.cmbAmend.Enabled = True 'allow amendment or
.cmbDelete.Enabled = True 'allow record deletion
.cmbAdd.Enabled = False 'don't want duplicate
If ListBox1.List(r, 4) = "Yes" Then
.optYes = True
ElseIf ListBox1.List(r, 4) = "No" Then
.optNo = True
End If
End With
End If
End Sub
Private Sub UserForm_Initialize()
Set MyData = Sheet1.Range("a5").CurrentRegion 'database
With Me
.Caption = "Database Example" 'userform caption
.Height = frmHt
.Width = frmWidth
End With
End Sub
Sub ClearControls()
With Me
For Each oCtrl In .Controls
Select Case TypeName(oCtrl)
Case "TextBox": oCtrl.Value = Empty
Case "OptionButton": oCtrl.Value = False
End Select
Next oCtrl
End With
End Sub
