leedsstuart
New Member
- Joined
- Oct 13, 2013
- Messages
- 8
Hi Guys,
I have created a form in VB and have borrowed some code for a search function from another form but am having difficulty getting it to run.
Private Sub chkQuote_Click()
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdNew_Click()
For Each Ctl In Me.Controls
If TypeName(Ctl) = "TextBox" Or TypeName(Ctl) = "ComboBox" Then
Ctl.Value = ""
ElseIf TypeName(Ctl) = "CheckBox" Then
Ctl.Value = False
End If
Next Ctl
End Sub
Private Sub cmdSearch_Click()
Dim f As Integer
Dim FirstAddress As String
Dim txtEAM As String 'what to find
Dim rSearch As Range 'range to search
Set rSearch = ws.Range("A1", Range("A65000").End(xlUp))
Set Rng = ws.Range("A2", Range("A65000").End(xlUp))
Set rFilter = ws.Range("A3", Range("F65000").End(xlUp))
strFindSheet1 = Me.txtEAM.Value 'what to look for
With rSearch
Set c = .Find(strFindSheet1, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
c.Select
With Me 'load entry to form
.txtEAM.Value = c.Offset(0, -1).Value
.txtPO.Value = c.Offset(0, 1).Value
.txtQR.Value = c.Offset(0, 2).Value
.txtLOC.Value = c.Offset(0, 3).Value
.txtCONT.Value = c.Offset(0, 4).Value
.txtQA.Value = c.Offset(0, 5).Value
.comFAM.Value = c.Offset(0, 6).Value
.comAUTH.Value = c.Offset(0, 7).Value
.comUL.Value = c.Offset(0, 8).Value
.txtCOM.Value = c.Offset(0, 9).Value
.cmdNEW.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
Select Case MsgBox("There are " & f & " instances of " & strFindSheet1, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries")
Case vbOK
With ws
If Not .AutoFilterMode Then .Range("B3").AutoFilter 'Column to be Filtered
rFilter.AutoFilter Field:=2, Criteria1:=strFindSheet1 'What to Filter For
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, 1).Value
.List(.ListCount - 1, 3) = c.Offset(0, 2).Value
.List(.ListCount - 1, 4) = c.Offset(0, 3).Value
.List(.ListCount - 1, 5) = c.Offset(0, 4).Value
.ColumnWidths = "1.1 in;2.5 in;1.1 in;2.75 in;1.25 in;5 in"
End With
Next c
End With
Case vbCancel
'do nothing
End Select
Me.Height = frmMaxH
Me.Width = frmMaxW
End If
Else: MsgBox "Can Not Find: " & strFindSheet1 'search failed
End If
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("A3").AutoFilter
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
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
.txtPO.Value = Trim(ListBox1.List(r, 0))
.txtQR.Value = Trim(ListBox1.List(r, 1))
.txtLOC.Value = Trim(ListBox1.List(r, 2))
.txtCONT.Value = Trim(ListBox1.List(r, 3))
.txtQA.Value = Trim(ListBox1.List(r, 4))
.comFAM.Value = Trim(ListBox1.List(r, 5))
.comAUTH.Value = Trim(ListBox1.List(r, 6))
.comUL.Value = Trim(ListBox1.List(r, 7))
.cmdAdd.Enabled = True
End With
End If
End Sub
Private Sub cmdSave_Click()
Dim RowCount As Long
Dim Ctl As Control
If Me.txtEAM.Value = "" Then
MsgBox "Please enter a EAM Ref Number.", vbExclamation, "EAM Ref"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtPO.Value = "" Then
MsgBox "Please enter a Purchase Order Number.", vbExclamation, "PO Number"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtQR.Value = "" Then
MsgBox "Please enter a Quote Ref.", vbExclamation, "Quote Ref"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtLOC.Value = "" Then
MsgBox "Please enter a Location.", vbExclamation, "Location"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtCONT.Value = "" Then
MsgBox "Please enter a Contractor.", vbExclamation, "Contractor"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtQA.Value = "" Then
MsgBox "Please enter a Quote Amount.", vbExclamation, "Quote Amount"
Me.txtEAM.SetFocus
Exit Sub
End If
If Not IsNumeric(Me.txtQA.Value) Then
MsgBox "The Quote Amount box must contain a number.", vbExclamation, "Quote Amount"
Me.txtQA.SetFocus
Exit Sub
End If
If Not IsDate(Me.DTPicker1.Value) Then
MsgBox "The Date box must contain a date.", vbExclamation, "Date Sent For Auth"
Me.DTPicker1.SetFocus
Exit Sub
End If
If Me.comFAM.Value = "" Then
MsgBox "Please enter a Authorising FAM.", vbExclamation, "Authorising FAM"
Me.txtEAM.SetFocus
Exit Sub
End If
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Sheet1").Range("A1")
.Offset(RowCount, 0).Value = Me.txtEAM.Value
.Offset(RowCount, 1).Value = Me.txtPO.Value
.Offset(RowCount, 2).Value = Me.txtQR.Value
.Offset(RowCount, 3).Value = Me.txtLOC.Value
.Offset(RowCount, 4).Value = Me.txtCONT.Value
.Offset(RowCount, 5).Value = Me.txtQA.Value
.Offset(RowCount, 6).Value = Me.comFAM.Value
.Offset(RowCount, 7).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 8).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 9).Value = Me.comAUTH.Value
.Offset(RowCount, 10).Value = Me.comUL.Value
.Offset(RowCount, 12).Value = Me.txtCOM.Value
If Me.chkQuote.Value = True Then
.Offset(RowCount, 14).Value = "Yes"
Else
.Offset(RowCount, 14).Value = "No"
End If
End With
For Each Ctl In Me.Controls
If TypeName(Ctl) = "TextBox" Or TypeName(Ctl) = "ComboBox" Then
Ctl.Value = ""
ElseIf TypeName(Ctl) = "CheckBox" Then
Ctl.Value = False
End If
Next Ctl
End Sub
Any help you can offer is gratefully accepted,
Thanks
Stu
I have created a form in VB and have borrowed some code for a search function from another form but am having difficulty getting it to run.
Private Sub chkQuote_Click()
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdNew_Click()
For Each Ctl In Me.Controls
If TypeName(Ctl) = "TextBox" Or TypeName(Ctl) = "ComboBox" Then
Ctl.Value = ""
ElseIf TypeName(Ctl) = "CheckBox" Then
Ctl.Value = False
End If
Next Ctl
End Sub
Private Sub cmdSearch_Click()
Dim f As Integer
Dim FirstAddress As String
Dim txtEAM As String 'what to find
Dim rSearch As Range 'range to search
Set rSearch = ws.Range("A1", Range("A65000").End(xlUp))
Set Rng = ws.Range("A2", Range("A65000").End(xlUp))
Set rFilter = ws.Range("A3", Range("F65000").End(xlUp))
strFindSheet1 = Me.txtEAM.Value 'what to look for
With rSearch
Set c = .Find(strFindSheet1, LookIn:=xlValues)
If Not c Is Nothing Then 'found it
c.Select
With Me 'load entry to form
.txtEAM.Value = c.Offset(0, -1).Value
.txtPO.Value = c.Offset(0, 1).Value
.txtQR.Value = c.Offset(0, 2).Value
.txtLOC.Value = c.Offset(0, 3).Value
.txtCONT.Value = c.Offset(0, 4).Value
.txtQA.Value = c.Offset(0, 5).Value
.comFAM.Value = c.Offset(0, 6).Value
.comAUTH.Value = c.Offset(0, 7).Value
.comUL.Value = c.Offset(0, 8).Value
.txtCOM.Value = c.Offset(0, 9).Value
.cmdNEW.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
Select Case MsgBox("There are " & f & " instances of " & strFindSheet1, vbOKCancel Or vbExclamation Or vbDefaultButton1, "Multiple entries")
Case vbOK
With ws
If Not .AutoFilterMode Then .Range("B3").AutoFilter 'Column to be Filtered
rFilter.AutoFilter Field:=2, Criteria1:=strFindSheet1 'What to Filter For
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, 1).Value
.List(.ListCount - 1, 3) = c.Offset(0, 2).Value
.List(.ListCount - 1, 4) = c.Offset(0, 3).Value
.List(.ListCount - 1, 5) = c.Offset(0, 4).Value
.ColumnWidths = "1.1 in;2.5 in;1.1 in;2.75 in;1.25 in;5 in"
End With
Next c
End With
Case vbCancel
'do nothing
End Select
Me.Height = frmMaxH
Me.Width = frmMaxW
End If
Else: MsgBox "Can Not Find: " & strFindSheet1 'search failed
End If
End With
If Sheet1.AutoFilterMode Then Sheet1.Range("A3").AutoFilter
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
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
.txtPO.Value = Trim(ListBox1.List(r, 0))
.txtQR.Value = Trim(ListBox1.List(r, 1))
.txtLOC.Value = Trim(ListBox1.List(r, 2))
.txtCONT.Value = Trim(ListBox1.List(r, 3))
.txtQA.Value = Trim(ListBox1.List(r, 4))
.comFAM.Value = Trim(ListBox1.List(r, 5))
.comAUTH.Value = Trim(ListBox1.List(r, 6))
.comUL.Value = Trim(ListBox1.List(r, 7))
.cmdAdd.Enabled = True
End With
End If
End Sub
Private Sub cmdSave_Click()
Dim RowCount As Long
Dim Ctl As Control
If Me.txtEAM.Value = "" Then
MsgBox "Please enter a EAM Ref Number.", vbExclamation, "EAM Ref"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtPO.Value = "" Then
MsgBox "Please enter a Purchase Order Number.", vbExclamation, "PO Number"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtQR.Value = "" Then
MsgBox "Please enter a Quote Ref.", vbExclamation, "Quote Ref"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtLOC.Value = "" Then
MsgBox "Please enter a Location.", vbExclamation, "Location"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtCONT.Value = "" Then
MsgBox "Please enter a Contractor.", vbExclamation, "Contractor"
Me.txtEAM.SetFocus
Exit Sub
End If
If Me.txtQA.Value = "" Then
MsgBox "Please enter a Quote Amount.", vbExclamation, "Quote Amount"
Me.txtEAM.SetFocus
Exit Sub
End If
If Not IsNumeric(Me.txtQA.Value) Then
MsgBox "The Quote Amount box must contain a number.", vbExclamation, "Quote Amount"
Me.txtQA.SetFocus
Exit Sub
End If
If Not IsDate(Me.DTPicker1.Value) Then
MsgBox "The Date box must contain a date.", vbExclamation, "Date Sent For Auth"
Me.DTPicker1.SetFocus
Exit Sub
End If
If Me.comFAM.Value = "" Then
MsgBox "Please enter a Authorising FAM.", vbExclamation, "Authorising FAM"
Me.txtEAM.SetFocus
Exit Sub
End If
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
With Worksheets("Sheet1").Range("A1")
.Offset(RowCount, 0).Value = Me.txtEAM.Value
.Offset(RowCount, 1).Value = Me.txtPO.Value
.Offset(RowCount, 2).Value = Me.txtQR.Value
.Offset(RowCount, 3).Value = Me.txtLOC.Value
.Offset(RowCount, 4).Value = Me.txtCONT.Value
.Offset(RowCount, 5).Value = Me.txtQA.Value
.Offset(RowCount, 6).Value = Me.comFAM.Value
.Offset(RowCount, 7).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 8).Value = Format(Now, "dd/mm/yyyy hh:nn:ss")
.Offset(RowCount, 9).Value = Me.comAUTH.Value
.Offset(RowCount, 10).Value = Me.comUL.Value
.Offset(RowCount, 12).Value = Me.txtCOM.Value
If Me.chkQuote.Value = True Then
.Offset(RowCount, 14).Value = "Yes"
Else
.Offset(RowCount, 14).Value = "No"
End If
End With
For Each Ctl In Me.Controls
If TypeName(Ctl) = "TextBox" Or TypeName(Ctl) = "ComboBox" Then
Ctl.Value = ""
ElseIf TypeName(Ctl) = "CheckBox" Then
Ctl.Value = False
End If
Next Ctl
End Sub
Any help you can offer is gratefully accepted,
Thanks
Stu