M
Mekinnik
I am using Office 2003. I have a database that stores manufacturer
information on 1 sheet ('MANCODE') and their product information on another
sheet ('ProCode') I have 2 user forms for entering the information. I am
trying to have when the user either enters in or chooses a manufacterers name
in userform ('FrmManu') from combobox ('CbxMfg') and clicks the next button
or the add button the name ('CbxMfg.Value') from combobox ('CbxMfg') gets
transfered to userform ('FrmProduct') combobox('CbxMfg') and searches upon
form initialize sheet ('Procode') columns 1 (manufacturer name) and 2
(product name) for every product that matches the 'CbxMfg' text value and
populates the combobox ('CbxProd') list so the user may choose the product
from the drop down, however if the search produces no products matching the
manufacturer name the a msgbox will show infoming the user to enter the new
product name. The current code I have only links the two comboxes togeter it
does not search for the names and that is what I am looking to do. Here is
the code for both user forms:
User form 'FrmManu'
Private Sub BtnAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Dim res As Variant
Set ws = Worksheets("MANCODE")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for the manufacturer name
If Trim(Me.TxtMan.Value) = "" Then
Me.TxtMan.SetFocus
MsgBox "Please enter the Manufacturer's name"
Exit Sub
End If
'find and copy state abbreviation to row 5
With Worksheets("Lists")
res = Application.VLookup(Me.CmbSt.Value, _
Worksheets("Lists").Range("A:B"), 2, False)
If IsError(res) Then
Else
ws.Cells(iRow, 4).Value = (res)
End If
End With
'copy the data to the database
Application.EnableEvents = False
ws.Cells(iRow, 2).Value = Me.TxtAdd.Value
ws.Cells(iRow, 3).Value = Me.TxtCity.Value
ws.Cells(iRow, 5).Value = Me.TxtZip.Value
ws.Cells(iRow, 6).Value = Me.TxtPhn.Value
Application.EnableEvents = True
'the sort will fire with this line.
ws.Cells(iRow, 1).Value = Me.TxtMan.Value
FrmProduct.CboMan.Value = Me.TxtMan.Value
'clear the data
Me.TxtMan.Value = ""
Me.TxtAdd.Value = ""
Me.TxtCity.Value = ""
Me.CmbSt.Value = ""
Me.TxtZip.Value = ""
Me.TxtPhn.Value = ""
'close window and return to product window
FrmManu.Hide
FrmProduct.Show
End Sub
Private Sub BtnDelete_Click()
Dim fRow As Long
On Error GoTo ender
fRow = Columns(1).Find(What:=TxtMan.Value, _
After:=Cells(5000, 1), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).Row
Rows(fRow).Delete
Exit Sub
ender:
MsgBox "Value not found"
End Sub
Private Sub BtnNext_Click()
FrmManu.Hide
FrmProduct.CbxMfg.Value = Me.TxtMan.Value
FrmProduct.Show
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Cancel = False
'Else
FrmManu.Hide
StrtUpFrm.Show
End If
End Sub
And userform 'FrmProduct'
Option Explicit
Option Compare Text
Private bEnableEvents As Boolean
Private MfgRange As Range
Private ProdRange As Range
Private Sub BtnAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Dim intMtoprow As Integer
Dim dept As String
Dim x As Integer
Dim R As Integer
Dim strCell As Variant
Dim y As Integer
Application.EnableEvents = False
Set ws = Worksheets("ProCode")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for the product name
If Trim(Me.CbxProd.Value) = "" Then
Me.CbxProd.SetFocus
MsgBox "Please enter the product name"
Exit Sub
End If
'creates the MSDS#
dept = Me.CboDept.Text
y = 0
intMtoprow = ws.Range("M1000").End(xlUp).Row
For R = 2 To intMtoprow
strCell = ws.Cells(R, 13).Value
If InStr(strCell, dept) = 1 And _
IsNumeric(Mid(strCell, Len(dept) + 1)) Then
x = CInt(Mid(strCell, Len(dept) + 1))
If x > y Then
y = x
End If
End If
Next R
'copy the data to the database
ws.Cells(iRow, 2).Value = Me.CbxProd.Value
ws.Cells(iRow, 3).Value = IIf(Me.CkBox1.Value, "Yes", "No")
ws.Cells(iRow, 4).Value = IIf(Me.CkBox2.Value, "Yes", "No")
ws.Cells(iRow, 5).Value = IIf(Me.CkBox3.Value, "Yes", "No")
ws.Cells(iRow, 6).Value = Me.CboFire.Value
ws.Cells(iRow, 7).Value = Me.CboHealth.Value
ws.Cells(iRow, 8).Value = Me.CboReact.Value
ws.Cells(iRow, 9).Value = Me.CboSpec.Value
ws.Cells(iRow, 10).Value = Me.CboDisp.Value
ws.Cells(iRow, 11).Value = Me.TxtQuan.Value
ws.Cells(iRow, 12).Value = Me.TxtDate.Value
ws.Cells(iRow, 13).Value = dept & Format(y + 1, "00#")
Application.EnableEvents = True
'the sort will fire with this line.
ws.Cells(iRow, 1).Value = Me.CbxMfg.Value
'FrmProduct.CbxMfg.Value = Me.TxtMan.Value
'clear the data
Me.CbxMfg.Value = ""
Me.CbxProd.Value = ""
Me.CkBox1.Value = False
Me.CkBox2.Value = False
Me.CkBox3.Value = False
Me.CboFire.Value = ""
Me.CboHealth.Value = ""
Me.CboReact.Value = ""
Me.CboSpec.Value = ""
Me.CboDisp.Value = ""
Me.TxtQuan.Value = ""
Me.TxtDate.Value = ""
End Sub
Private Sub BtnClose_Click()
FrmProduct.Hide
StrtUpFrm.Show
End Sub
Private Sub BtnDelete_Click()
Dim fRow As Long
On Error GoTo ender
'finds product name in column 'B' _
then deletes the entire column
fRow = Columns(2).Find(What:=CbxProd.Value, _
After:=Cells(5000, 2), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).Row
Rows(fRow).Delete
Exit Sub
Me.CboMan.Value = ""
Me.TxtProd.Value = ""
Me.CkBox1.Value = False
Me.CkBox2.Value = False
Me.CkBox3.Value = False
Me.CboFire.Value = ""
Me.CboHealth.Value = ""
Me.CboReact.Value = ""
Me.CboSpec.Value = ""
Me.CboDisp.Value = ""
Me.TxtQuan.Value = ""
Me.TxtDate.Value = ""
ender:
MsgBox "Value not found"
End Sub
Private Sub CboMan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmProduct.Hide
FrmManu.Show
End Sub
Private Sub CbxMfg_Change()
Dim R As Range
Dim MfgName As String
If bEnableEvents = False Then
Exit Sub
End If
With Me.CbxMfg
If .ListIndex >= 0 Then
MfgName = .List(.ListIndex)
End If
End With
bEnableEvents = False
With Me.CbxProd
..Clear
For Each R In MfgRange
If R.Text = MfgName Then
If R(1, 2).Text <> vbNullString Then
.AddItem R(1, 2).Text
End If
End If
Next R
If .ListCount > 0 Then
.ListIndex = 0
End If
bEnableEvents = True
If .ListCount = 0 Then
MsgBox "This is a new Manufacturer add the product Information."
End If
End With
End Sub
Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub
Private Sub UserForm_Initialize()
Dim Coll As Collection
Dim MfgName As String
Dim P As Range
Dim N As Long
Set Coll = New Collection
Set MfgRange = Worksheets("ProCode").Range("A2:A1000")
Set ProdRange = Worksheets("ProCode").Range("B2:B1000")
On Error Resume Next
For Each P In MfgRange
Coll.Add Item:=P, key:=P
Next P
bEnableEvents = False
With Me.CbxMfg
.Clear
For N = 1 To Coll.Count
.AddItem Coll(N)
Next N
If .ListCount > 0 Then
.ListIndex = 0
MfgName = .List(0)
For Each P In MfgRange
If P.Text = MfgName Then
Me.CbxProd.AddItem P(1, 2).Text
End If
Next P
If Me.CbxProd.ListCount > 0 Then
Me.CbxProd.ListIndex = 0
End If
End If
End With
bEnableEvents = True
CboFire.List = Sheets("Lists").Range("D25").Value
CboHealth.List = Sheets("Lists").Range("D25").Value
CboReact.List = Sheets("Lists").Range("D25").Value
CboDisp.List = Sheets("Lists").Range("E2:E4").Value
CboDept.List = Sheets("Lists").Range("C2:C10").Value
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub
information on 1 sheet ('MANCODE') and their product information on another
sheet ('ProCode') I have 2 user forms for entering the information. I am
trying to have when the user either enters in or chooses a manufacterers name
in userform ('FrmManu') from combobox ('CbxMfg') and clicks the next button
or the add button the name ('CbxMfg.Value') from combobox ('CbxMfg') gets
transfered to userform ('FrmProduct') combobox('CbxMfg') and searches upon
form initialize sheet ('Procode') columns 1 (manufacturer name) and 2
(product name) for every product that matches the 'CbxMfg' text value and
populates the combobox ('CbxProd') list so the user may choose the product
from the drop down, however if the search produces no products matching the
manufacturer name the a msgbox will show infoming the user to enter the new
product name. The current code I have only links the two comboxes togeter it
does not search for the names and that is what I am looking to do. Here is
the code for both user forms:
User form 'FrmManu'
Private Sub BtnAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Dim res As Variant
Set ws = Worksheets("MANCODE")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for the manufacturer name
If Trim(Me.TxtMan.Value) = "" Then
Me.TxtMan.SetFocus
MsgBox "Please enter the Manufacturer's name"
Exit Sub
End If
'find and copy state abbreviation to row 5
With Worksheets("Lists")
res = Application.VLookup(Me.CmbSt.Value, _
Worksheets("Lists").Range("A:B"), 2, False)
If IsError(res) Then
Else
ws.Cells(iRow, 4).Value = (res)
End If
End With
'copy the data to the database
Application.EnableEvents = False
ws.Cells(iRow, 2).Value = Me.TxtAdd.Value
ws.Cells(iRow, 3).Value = Me.TxtCity.Value
ws.Cells(iRow, 5).Value = Me.TxtZip.Value
ws.Cells(iRow, 6).Value = Me.TxtPhn.Value
Application.EnableEvents = True
'the sort will fire with this line.
ws.Cells(iRow, 1).Value = Me.TxtMan.Value
FrmProduct.CboMan.Value = Me.TxtMan.Value
'clear the data
Me.TxtMan.Value = ""
Me.TxtAdd.Value = ""
Me.TxtCity.Value = ""
Me.CmbSt.Value = ""
Me.TxtZip.Value = ""
Me.TxtPhn.Value = ""
'close window and return to product window
FrmManu.Hide
FrmProduct.Show
End Sub
Private Sub BtnDelete_Click()
Dim fRow As Long
On Error GoTo ender
fRow = Columns(1).Find(What:=TxtMan.Value, _
After:=Cells(5000, 1), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).Row
Rows(fRow).Delete
Exit Sub
ender:
MsgBox "Value not found"
End Sub
Private Sub BtnNext_Click()
FrmManu.Hide
FrmProduct.CbxMfg.Value = Me.TxtMan.Value
FrmProduct.Show
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Cancel = False
'Else
FrmManu.Hide
StrtUpFrm.Show
End If
End Sub
And userform 'FrmProduct'
Option Explicit
Option Compare Text
Private bEnableEvents As Boolean
Private MfgRange As Range
Private ProdRange As Range
Private Sub BtnAdd_Click()
Dim iRow As Long
Dim ws As Worksheet
Dim intMtoprow As Integer
Dim dept As String
Dim x As Integer
Dim R As Integer
Dim strCell As Variant
Dim y As Integer
Application.EnableEvents = False
Set ws = Worksheets("ProCode")
'find first empty row in database
iRow = ws.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
'check for the product name
If Trim(Me.CbxProd.Value) = "" Then
Me.CbxProd.SetFocus
MsgBox "Please enter the product name"
Exit Sub
End If
'creates the MSDS#
dept = Me.CboDept.Text
y = 0
intMtoprow = ws.Range("M1000").End(xlUp).Row
For R = 2 To intMtoprow
strCell = ws.Cells(R, 13).Value
If InStr(strCell, dept) = 1 And _
IsNumeric(Mid(strCell, Len(dept) + 1)) Then
x = CInt(Mid(strCell, Len(dept) + 1))
If x > y Then
y = x
End If
End If
Next R
'copy the data to the database
ws.Cells(iRow, 2).Value = Me.CbxProd.Value
ws.Cells(iRow, 3).Value = IIf(Me.CkBox1.Value, "Yes", "No")
ws.Cells(iRow, 4).Value = IIf(Me.CkBox2.Value, "Yes", "No")
ws.Cells(iRow, 5).Value = IIf(Me.CkBox3.Value, "Yes", "No")
ws.Cells(iRow, 6).Value = Me.CboFire.Value
ws.Cells(iRow, 7).Value = Me.CboHealth.Value
ws.Cells(iRow, 8).Value = Me.CboReact.Value
ws.Cells(iRow, 9).Value = Me.CboSpec.Value
ws.Cells(iRow, 10).Value = Me.CboDisp.Value
ws.Cells(iRow, 11).Value = Me.TxtQuan.Value
ws.Cells(iRow, 12).Value = Me.TxtDate.Value
ws.Cells(iRow, 13).Value = dept & Format(y + 1, "00#")
Application.EnableEvents = True
'the sort will fire with this line.
ws.Cells(iRow, 1).Value = Me.CbxMfg.Value
'FrmProduct.CbxMfg.Value = Me.TxtMan.Value
'clear the data
Me.CbxMfg.Value = ""
Me.CbxProd.Value = ""
Me.CkBox1.Value = False
Me.CkBox2.Value = False
Me.CkBox3.Value = False
Me.CboFire.Value = ""
Me.CboHealth.Value = ""
Me.CboReact.Value = ""
Me.CboSpec.Value = ""
Me.CboDisp.Value = ""
Me.TxtQuan.Value = ""
Me.TxtDate.Value = ""
End Sub
Private Sub BtnClose_Click()
FrmProduct.Hide
StrtUpFrm.Show
End Sub
Private Sub BtnDelete_Click()
Dim fRow As Long
On Error GoTo ender
'finds product name in column 'B' _
then deletes the entire column
fRow = Columns(2).Find(What:=CbxProd.Value, _
After:=Cells(5000, 2), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).Row
Rows(fRow).Delete
Exit Sub
Me.CboMan.Value = ""
Me.TxtProd.Value = ""
Me.CkBox1.Value = False
Me.CkBox2.Value = False
Me.CkBox3.Value = False
Me.CboFire.Value = ""
Me.CboHealth.Value = ""
Me.CboReact.Value = ""
Me.CboSpec.Value = ""
Me.CboDisp.Value = ""
Me.TxtQuan.Value = ""
Me.TxtDate.Value = ""
ender:
MsgBox "Value not found"
End Sub
Private Sub CboMan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmProduct.Hide
FrmManu.Show
End Sub
Private Sub CbxMfg_Change()
Dim R As Range
Dim MfgName As String
If bEnableEvents = False Then
Exit Sub
End If
With Me.CbxMfg
If .ListIndex >= 0 Then
MfgName = .List(.ListIndex)
End If
End With
bEnableEvents = False
With Me.CbxProd
..Clear
For Each R In MfgRange
If R.Text = MfgName Then
If R(1, 2).Text <> vbNullString Then
.AddItem R(1, 2).Text
End If
End If
Next R
If .ListCount > 0 Then
.ListIndex = 0
End If
bEnableEvents = True
If .ListCount = 0 Then
MsgBox "This is a new Manufacturer add the product Information."
End If
End With
End Sub
Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub
Private Sub UserForm_Initialize()
Dim Coll As Collection
Dim MfgName As String
Dim P As Range
Dim N As Long
Set Coll = New Collection
Set MfgRange = Worksheets("ProCode").Range("A2:A1000")
Set ProdRange = Worksheets("ProCode").Range("B2:B1000")
On Error Resume Next
For Each P In MfgRange
Coll.Add Item:=P, key:=P
Next P
bEnableEvents = False
With Me.CbxMfg
.Clear
For N = 1 To Coll.Count
.AddItem Coll(N)
Next N
If .ListCount > 0 Then
.ListIndex = 0
MfgName = .List(0)
For Each P In MfgRange
If P.Text = MfgName Then
Me.CbxProd.AddItem P(1, 2).Text
End If
Next P
If Me.CbxProd.ListCount > 0 Then
Me.CbxProd.ListIndex = 0
End If
End If
End With
bEnableEvents = True
CboFire.List = Sheets("Lists").Range("D25").Value
CboHealth.List = Sheets("Lists").Range("D25").Value
CboReact.List = Sheets("Lists").Range("D25").Value
CboDisp.List = Sheets("Lists").Range("E2:E4").Value
CboDept.List = Sheets("Lists").Range("C2:C10").Value
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Please use the 'CLOSE' button", vbExclamation
End If
End Sub