'---------------------------------------------------------------------------------------
' CREDIT TO :
' 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
' Amended : 27/04/2013
'---------------------------------------------------------------------------------------
Dim Ws As Worksheet
Dim MyData As Range, c As Range, rFound As Range, rng As Range
Dim r As Long
Const frmMax As Long = 450
Const frmHt As Long = 450
Const frmWidth As Long = 450
Dim oCtrl As MSForms.Control
Private Sub cmbAdd_Click()
'next empty cell in column A
Set c = MyData.Cells(MyData.Rows.Count, 1).Offset(1)
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
c.Offset(0, 4).Value = .TextBox5.Value
If Me.optYes Then
c.Offset(0, 5).Value = "Open"
ElseIf .optNo Then
c.Offset(0, 5).Value = "Closed"
End If
'clear the form
'resize database
Set MyData = c.CurrentRegion
Me.ScrollBar1.Max = MyData.Rows.Count
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
If c Is Nothing Then Set c = Ws.Cells(r, 1)
c.EntireRow.Delete 'remove entry by deleting row
Set MyData = Ws.Range("a8").CurrentRegion 'database
'restore form settings
With Me
.cmbAmend.Enabled = False 'prevent accidental use
.cmbDelete.Enabled = False 'prevent accidental use
.cmbAdd.Enabled = True 'restore use
.ScrollBar1.Max = MyData.Rows.Count
'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 f As Integer
frmMain.Height = 450
frmMain.Width = 450
strFind = Me.TextBox1.Value 'what to look for
With MyData
.AutoFilter
Set c = .Find(strFind, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
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
.TextBox5.Value = c.Offset(0, 4).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, 5).Value = "Open" Then .optYes = True
If c.Offset(0, 5).Value = "Closed" Then .optYes = True
r = c.Row
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
End Sub
Private Sub cmbAmend_Click()
Application.ScreenUpdating = False
If r <= 0 Then Exit Sub
Set c = Ws.Cells(r, 1)
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
c.Offset(0, 4).Value = Me.TextBox5.Value
If Me.optYes Then
c.Offset(0, 5).Value = "Open"
ElseIf Me.optNo Then
c.Offset(0, 5).Value = "Closed"
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
'resize database
Set MyData = c.CurrentRegion
Me.ScrollBar1.Max = MyData.Rows.Count
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Sub FindAll()
Dim wesTemp As Worksheet
Dim strFind As String 'what to find
strFind = Me.TextBox1.Value
If Not Ws.AutoFilterMode Then MyData.AutoFilter
MyData.AutoFilter Field:=1, Criteria1:=strFind
Me.ListBox1.Clear
For Each c In MyData.Columns(1).SpecialCells(xlCellTypeVisible)
With 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
.List(.ListCount - 1, 5) = c.Offset(0, 5).Value
.List(.ListCount - 1, 6) = c.Row
End With
Next c
End Sub
Private Sub cmbLast_Click()
Dim LastCl As Range
With MyData
Set LastCl = .Cells(.Rows.Count, 1)
End With
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
.TextBox5.Value = LastCl.Offset(0, 4).Value
If LastCl.Offset(0, 5).Value = "Open" Then
.optYes = True
Else: .optNo = True
End If
End With
End Sub
Private Sub cmnbFirst_Click()
Dim FirstCl As Range
'first data Entry
Set FirstCl = MyData.Cells(2, 1)
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
.TextBox5.Value = FirstCl.Offset(0, 4).Value
If FirstCl.Offset(0, 5).Value = "Open" Then
.optYes = True
Else: .optNo = True
End If
End With
End Sub
Private Sub ListBox1_Click()
Set c = Nothing
With Me.ListBox1
If .ListIndex = -1 Then 'not selected
MsgBox " No selection made"
ElseIf .ListIndex >= 1 Then 'User has selected
r = Val(.List(.ListIndex, .ColumnCount - 1))
End If
End With
With Me
.TextBox1.Value = .ListBox1.List(.ListBox1.ListIndex, 0)
.TextBox2.Value = .ListBox1.List(.ListBox1.ListIndex, 1)
.TextBox3.Value = .ListBox1.List(.ListBox1.ListIndex, 2)
.TextBox4.Value = .ListBox1.List(.ListBox1.ListIndex, 4)
.TextBox5.Value = .ListBox1.List(.ListBox1.ListIndex, 5)
r = .ListBox1.List(.ListBox1.ListIndex, 6)
.cmbAmend.Enabled = True 'allow amendment or
.cmbDelete.Enabled = True 'allow record deletion
.cmbAdd.Enabled = False 'don't want duplicate
If ListBox1.List(.ListBox1.ListIndex, 6) = "Open" Then
.optYes = True
Else: .optNo = True
End If
End With
End Sub
Private Sub ScrollBar1_Change()
Dim Rw As Long
Rw = Me.ScrollBar1.Value
With Me
.cmbAmend.Enabled = False
.cmbDelete.Enabled = False
.cmbAdd.Enabled = True
.TextBox1.Value = MyData.Cells(Rw, 1).Value
.TextBox2.Value = MyData.Cells(Rw, 2).Value
.TextBox3.Value = MyData.Cells(Rw, 3).Value
.TextBox4.Value = MyData.Cells(Rw, 4).Value
.TextBox5.Value = MyData.Cells(Rw, 5).Value
If MyData.Cells(Rw, 6).Value = "Open" Then
.optYes = True
Else: .optNo = True
End If
End With
End Sub
Private Sub UserForm_Initialize()
'change sheet name and Range here
Set Ws = Sheet1
Set MyData = Ws.Range("a8").CurrentRegion 'database
With Me
.Caption = "Database Example" 'userform caption
.Height = frmHt
.Width = frmWidth
.ScrollBar1.Max = MyData.Rows.Count
.ScrollBar1.Min = 2
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
Private Sub UserForm_Terminate()
Dim Target
If Sheet1.AutoFilterMode Then Sheet1.Range("A6").AutoFilter 'resets autofilter to all data
'autosort Col A
Dim lastrow As Long
lastrow = Cells(Rows.Count, 6).End(xlUp).Row
Range("A6:F" & lastrow).Sort key1:=Range("A6:A" & lastrow), _
order1:=xlAscending, Header:=xlNo
'auto saves the workbook
ThisWorkbook.Save
End Sub
