Visual Basic coding for excel database - am tearing my hair out!
I am trying to build a database in Excel 2002 / Windows XP.
I have 5 columns starting from row B they are as follows..
TITLE/ PUBLISHER / YEAR OF PUBLICATION /DATA TYPE /ELECTRONIC /HARDCOPY
/DESCRIPTION /WEB LOCATION/NETWORK LOCATION /HARDCOPY LOCATION
/CYCLING/WALKING/ACCESSIBILITY
This picture best illiustrates what the spreadsheet looks like..
When I click on the start button it brings up a form. This form is for
people to populate the sheet with data and to search. It is the search
function I am having problems with.
When there are multiple results for the publciation title, you have to
click FIND ALL to view them. Problem is it only diaplays the TITLE /
PUBLISHER/ YEAR OF PUBLICATION / and DATA TYPE values. Furthermore it has
problems displaying correct values for the check boxes.
I need it to display values for all fields, accurately. If there are
multiple results, clicking on the relevant record in the listbox and then
clicking SELECT should result in switching between records on the fly with
the correct results being displayed.
Second problem isnt so much a problem, but an enhancement. Instead of
having to click on the FIND ALL button when there are multple results, I
would like the results to be displayed automatically in the list box
without user intervention. How so?
The code is here:
Option Explicit
Dim MyArray(6, 6)
Public MyData As Range, c As Range
Private Sub CheckBox1_Click()
End Sub
Private Sub CheckBox2_Click()
End Sub
Private Sub Clearbutton_Click()
Me.TextBox1.Value = vbNullString
Me.TextBox2.Value = vbNullString
Me.TextBox3.Value = vbNullString
Me.TextBox4.Value = vbNullString
Me.CheckBox1.Value = vbNullString
Me.CheckBox2.Value = vbNullString
Me.txtDesc.Value = vbNullString
Me.txtLocate.Value = vbNullString
Me.txtLocate2.Value = vbNullString
Me.txtLocate3.Value = vbNullString
Me.OptionButton1.Value = vbNullString
Me.OptionButton2.Value = vbNullString
Me.OptionButton3.Value = vbNullString
End Sub
Private Sub cmbAdd_Click()
'next empty cell in column A
Set c = Range("b65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'write userform entries to database
c.Value = Me.TextBox1.Value
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.CheckBox1.Value
c.Offset(0, 5).Value = Me.CheckBox2.Value
c.Offset(0, 6).Value = Me.txtDesc.Value
c.Offset(0, 7).Value = Me.txtLocate.Value
c.Offset(0, 8).Value = Me.txtLocate2.Value
c.Offset(0, 9).Value = Me.txtLocate3.Value
c.Offset(0, 10).Value = Me.OptionButton1.Value
c.Offset(0, 11).Value = Me.OptionButton2.Value
c.Offset(0, 12).Value = Me.OptionButton3.Value
'clear the form
With Me
.TextBox1.Value = vbNullString
.TextBox2.Value = vbNullString
.TextBox3.Value = vbNullString
.TextBox4.Value = vbNullString
.CheckBox1.Value = vbNullString
.CheckBox2.Value = vbNullString
.txtDesc.Value = vbNullString
.txtLocate.Value = vbNullString
.txtLocate2.Value = vbNullString
.txtLocate3.Value = vbNullString
.OptionButton1.Value = vbNullString
.OptionButton2.Value = vbNullString
.OptionButton3.Value = vbNullString
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
.TextBox1.Value = vbNullString
.TextBox2.Value = vbNullString
.TextBox3.Value = vbNullString
.TextBox4.Value = vbNullString
.CheckBox1.Value = vbNullString
.CheckBox2.Value = vbNullString
.txtDesc.Value = vbNullString
.txtLocate.Value = vbNullString
.txtLocate2.Value = vbNullString
.txtLocate3.Value = vbNullString
.OptionButton1.Value = vbNullString
.OptionButton2.Value = vbNullString
.OptionButton3.Value = vbNullString
End With
Case vbNo
Exit Sub 'cancelled
End Select
Application.ScreenUpdating = True
End Sub
Private Sub cmbFind_Click()
Dim strFind, FirstAddress As String 'what to find
Dim rSearch As Range 'range to search
Set rSearch = Sheet1.Range("b6", Range("b65536").End(xlUp))
strFind = Me.TextBox1.Value 'what to look for
Dim f As Integer
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
.CheckBox1.Value = c.Offset(0, 4).Value
.CheckBox2.Value = c.Offset(0, 5).Value
.txtDesc.Value = c.Offset(0, 6).Value
.txtLocate.Value = c.Offset(0, 7).Value
.txtLocate2.Value = c.Offset(0, 8).Value
.txtLocate3.Value = c.Offset(0, 9).Value
.OptionButton1.Value = c.Offset(0, 10).Value
.OptionButton2.Value = c.Offset(0, 11).Value
.OptionButton3.Value = c.Offset(0, 12).Value
.cmbAmend.Enabled = True 'allow amendment or
.cmbDelete.Enabled = True 'allow record deletion
.cmbAdd.Enabled = False 'don't want to duplicate
record
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
MsgBox "There are " & f & " instances of " & strFind
Me.Height = 589
End If
Else: MsgBox strFind & " not listed" 'search failed
End If
End With
End Sub
Private Sub cmbAmend_Click()
Application.ScreenUpdating = False
Set c = ActiveCell ' c selected by Find
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.CheckBox1.Value
c.Offset(0, 5).Value = Me.CheckBox2.Value
c.Offset(0, 6).Value = Me.txtDesc.Value
c.Offset(0, 7).Value = Me.txtLocate.Value
c.Offset(0, 8).Value = Me.txtLocate2.Value
c.Offset(0, 9).Value = Me.txtLocate3.Value
c.Offset(0, 10).Value = Me.OptionButton1.Value
c.Offset(0, 11).Value = Me.OptionButton2.Value
c.Offset(0, 12).Value = Me.OptionButton3.Value
'restore Form
With Me
.cmbAmend.Enabled = False
.cmbDelete.Enabled = False
.cmbAdd.Enabled = True
.TextBox1.Value = vbNullString
.TextBox2.Value = vbNullString
.TextBox3.Value = vbNullString
.TextBox4.Value = vbNullString
.CheckBox1.Value = vbNullString
.CheckBox2.Value = vbNullString
.txtDesc.Value = vbNullString
.txtLocate.Value = vbNullString
.txtLocate2.Value = vbNullString
.txtLocate3.Value = vbNullString
.OptionButton1.Value = vbNullString
.OptionButton2.Value = vbNullString
.OptionButton3.Value = vbNullString
End With
Application.ScreenUpdating = True
End Sub
Private Sub cmbFindAll_Click()
Dim FirstAddress As String
Dim strFind As String 'what to find
Dim rSearch As Range 'range to search
Dim fndA, fndB, fndC, fndD As String
Dim head1, head2, head3, head4, head5 As String 'heading s for list
Dim i As Integer
i = 1
Set rSearch = Sheet1.Range("b6", Range("b65536").End(xlUp))
strFind = Me.TextBox1.Value
With rSearch
Set c = .Find(strFind, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
c.Select
'load the headings
head1 = Range("b5").Value
head2 = Range("c5").Value
head3 = Range("d5").Value
head4 = Range("e5").Value
head4 = Range("f5").Value
head4 = Range("g5").Value
head5 = Range("g5").Value
With Me.ListBox1
MyArray(0, 0) = head1
MyArray(0, 1) = head2
MyArray(0, 2) = head3
MyArray(0, 3) = head4
MyArray(0, 4) = head5
End With
FirstAddress = c.Address
Do
'Load details into Listbox
fndA = c.Value
fndB = c.Offset(0, 1).Value
fndC = c.Offset(0, 2).Value
fndD = c.Offset(0, 3).Value
'here
MyArray(i, 0) = fndA
MyArray(i, 1) = fndB
MyArray(i, 2) = fndC
MyArray(i, 3) = fndD
i = i + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
'Load data into LISTBOX
Me.ListBox1.List() = MyArray
End Sub
Private Sub cmbLast_Click()
Dim LastCl As Range
Set LastCl = Range("b65536").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
.CheckBox1.Value = LastCl.Offset(0, 4).Value
.CheckBox2.Value = LastCl.Offset(0, 5).Value
.txtDesc.Value = LastCl.Offset(0, 6).Value
.txtLocate.Value = LastCl.Offset(0, 7).Value
.txtLocate2.Value = LastCl.Offset(0, 8).Value
.txtLocate3.Value = LastCl.Offset(0, 9).Value
.OptionButton1.Value = LastCl.Offset(0, 10).Value
.OptionButton2.Value = LastCl.Offset(0, 11).Value
.OptionButton3.Value = LastCl.Offset(0, 12).Value
End With
End Sub
Private Sub cmbSelect_Click()
Dim r As Integer
If Me.ListBox1.ListIndex = -1 Then 'not selected
MsgBox " No selection made"
ElseIf Me.ListBox1.ListIndex >= 0 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)
.CheckBox1.Value = c.Offset(0, 4).Value
.CheckBox2.Value = c.Offset(0, 5).Value
.OptionButton1.Value = c.Offset(0, 10).Value
.OptionButton2.Value = c.Offset(0, 11).Value
.OptionButton3.Value = c.Offset(0, 12).Value
'CONTINUE HERE
.cmbAmend.Enabled = True 'allow amendment or
.cmbDelete.Enabled = True 'allow record deletion
.cmbAdd.Enabled = False 'don't want duplicate
End With
End If
End Sub
Private Sub cmnbFirst_Click()
Dim FirstCl As Range
'first data Entry
Set FirstCl = Range("b1").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
.CheckBox1.Value = FirstCl.Offset(0, 4).Value
.CheckBox2.Value = FirstCl.Offset(0, 5).Value
.txtDesc.Value = FirstCl.Offset(0, 6).Value
.txtLocate.Value = FirstCl.Offset(0, 7).Value
.txtLocate2.Value = FirstCl.Offset(0, 8).Value
.txtLocate3.Value = FirstCl.Offset(0, 9).Value
.OptionButton1.Value = FirstCl.Offset(0, 10).Value
.OptionButton2.Value = FirstCl.Offset(0, 11).Value
.OptionButton3.Value = FirstCl.Offset(0, 12).Value
End With
End Sub
Private Sub ComboBoxCat_Change()
End Sub
Private Sub ComboBoxFormat_Change()
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub Frame4_Click()
End Sub
Private Sub Label1_Click()
End Sub
Private Sub Label2_Click()
End Sub
Private Sub Label8_Click()
End Sub
Private Sub ListBox1_Click()
End Sub
Private Sub OptionButton3_Click()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub TextBox4_Change()
End Sub
Private Sub txtDesc_Change()
End Sub
Private Sub UserForm_Initialize()
Set MyData = Sheet1.Range("b5").CurrentRegion 'database
With Me
.Caption = "CWA Articles & Publications Database" 'userform
caption
End With
TextBox4.List = Array("Report", "Study", "Leaflet", "Presentation")
End Sub
