M
Mekinnik
Why is it that when I enter a name into CboMan (combobox) it will not #1
allow me to bring up the userform and #2 when I do tell it to show the
userform it gets stuck in a loop and gives me an error that goes back to the
from.show line of code? Here is my code for userform #1.
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 y As Integer
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.TxtProd.Value) = "" Then
Me.TxtProd.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
Application.EnableEvents = False
ws.Cells(iRow, 2).Value = Me.TxtProd.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.CboMan.Value
FrmProduct.CboMan.Value = Me.CboMan.Value
'clear the data
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 = ""
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:=TxtProd.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_Change()
Dim R As Range
Dim MfgName As String
If bEnableEvents = False Then
Exit Sub
End If
With Me.CboMan
If .ListIndex >= 0 Then
MfgName = .List(.ListIndex)
End If
End With
With Me.CbxProd
bEnableEvents = False
.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 "No products match manufacturer:" & MfgName & ""
FrmManu.Show
End If
End With
End Sub
Private Sub CboMan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmProduct.Hide
FrmManu.Show
End Sub
Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub
Private Sub UserForm_Initialize()
Dim MfgName As String
Dim Coll As Collection
Dim R 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 R In MfgRange
Coll.Add Item:=R, key:=R
Next R
bEnableEvents = False
With Me.CboMan
.Clear
For n = 1 To Coll.Count
.AddItem Coll(n)
Next n
If .ListCount > 0 Then
.ListIndex = 0
MfgName = .List(0)
For Each R In MfgRange
If R.Text = MfgName Then
Me.CbxProd.AddItem R(1, 2).Text
End If
Next R
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
allow me to bring up the userform and #2 when I do tell it to show the
userform it gets stuck in a loop and gives me an error that goes back to the
from.show line of code? Here is my code for userform #1.
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 y As Integer
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.TxtProd.Value) = "" Then
Me.TxtProd.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
Application.EnableEvents = False
ws.Cells(iRow, 2).Value = Me.TxtProd.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.CboMan.Value
FrmProduct.CboMan.Value = Me.CboMan.Value
'clear the data
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 = ""
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:=TxtProd.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_Change()
Dim R As Range
Dim MfgName As String
If bEnableEvents = False Then
Exit Sub
End If
With Me.CboMan
If .ListIndex >= 0 Then
MfgName = .List(.ListIndex)
End If
End With
With Me.CbxProd
bEnableEvents = False
.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 "No products match manufacturer:" & MfgName & ""
FrmManu.Show
End If
End With
End Sub
Private Sub CboMan_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmProduct.Hide
FrmManu.Show
End Sub
Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub
Private Sub UserForm_Initialize()
Dim MfgName As String
Dim Coll As Collection
Dim R 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 R In MfgRange
Coll.Add Item:=R, key:=R
Next R
bEnableEvents = False
With Me.CboMan
.Clear
For n = 1 To Coll.Count
.AddItem Coll(n)
Next n
If .ListCount > 0 Then
.ListIndex = 0
MfgName = .List(0)
For Each R In MfgRange
If R.Text = MfgName Then
Me.CbxProd.AddItem R(1, 2).Text
End If
Next R
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