Help with applying code

M

Mekinnik

Can someone please look over the code I have posted and please tell me why
its that when it is applied to my current project it will not work right. It
is suppose to work like this. When you select a value from combobox1 it
checks to see it it is on sheet1 column'A' and if it is return what ever
value matches that value to combobox2 from sheet2 column'B'. This is what
sheet 2 looks like.

column A column B
a 1
a 2
b 1
c 1
a 3

For ever "a" in column 'a' it is suppose to return the column 'B' value so
(1,2,3). Whuch works just fine in the test version, however when it is
applied to my project code it does not work right it return to combobox2 the
same values as combobox1 which is wrong. Here is the code from both my forms.

**My test from code**

Private Sub Cbo1_Change()
Application.EnableEvents = True

Dim S As String
Dim V As Variant
Dim J As Range
'catches user input and checks to see if it's
S = Me.Cbo1.Text
V = Application.Match(S, Worksheets("sheet1").Range("A1:A10"), 0)
If IsError(V) = True Then
frm1.Hide
frm2.Show
End If
If IsError(V) = False Then
With Me.Cbo2
..Clear
For Each J In Worksheets("test").Range("A1:A18")
If J.Text = S Then
..AddItem J(1, 2)
End If
Next J
..SetFocus
If .ListCount > 0 Then
..ListIndex = 0
End If
End With
End If
End Sub

Private Sub UserForm_Initialize()
Cbo1.RowSource = Worksheets("sheet1").Range("A1:A10").Address(external:=True)

End Sub

**My project form code**


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 CbxMfg_Change()
Dim S As String
Dim V As Variant
Dim J As Range
S = Me.CbxMfg.Text
V = Application.Match(S, Worksheets("MANCODE").Range("A2:A1000"), 0)
If IsError(V) = True Then
FrmProduct.Hide
FrmManu.Show
End If
If IsError(V) = False Then
With Me.CbxProd
' .Clear
For Each J In Worksheets("ProCode").Range("A2:A1000")
If J.Text = S Then
..AddItem J(1, 2)
End If
Next J
..SetFocus
If .ListCount > 0 Then
..ListIndex = 0
End If
End With
End If
End Sub

Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub

Private Sub UserForm_Initialize()
CbxMfg.RowSource =
Worksheets("MANCODE").Range("A2:A1000").Address(external:=True)
'CboFire.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboHealth.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboReact.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboDisp.RowSource =
Worksheets("Lists").Range("E2:E4").Address(external:=True)
'CboDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(external:=True)

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Cancel = False
FrmManu.Hide
StrtUpFrm.Show
End If
End Sub
 
O

OssieMac

Hi,

Have made a couple of adjustments and also note the comments. The following
now appears to test OK. Have not tested all of the code that you posted, only
the part to populate the second combo box based on the selection in the first
combo.

Also everyone appreciates an acknowledgement to an answer (Whether it works
or not). I see that you have used code from a previous answer that I provided
but you didn't previously acknowledge whether it answered your question
satisfactorily.

Private Sub UserForm_Initialize()

CbxMfg.RowSource = _
Worksheets("MANCODE").Range("A2:A1000").Address(external:=True)

'CboFire.RowSource = _
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboHealth.RowSource = _
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboReact.RowSource = _
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboDisp.RowSource = _
Worksheets("Lists").Range("E2:E4").Address(external:=True)
'CboDept.RowSource = _
Worksheets("Lists").Range("C2:C10").Address(external:=True)

End Sub


Private Sub CbxMfg_Change()
Dim S As String
Dim V As Variant
Dim J As Range
S = Me.CbxMfg.Text

'V = Application.Match(S, Worksheets("MANCODE") _
.Range("A2:A1000"), 0)

'Note: V in above line will never be an error
'because it is a numeric value representing
'the position in range A2:A1000 of the selection
'and the selection is the Rowsource of the combo so
'it must be found in that range.

'Is it supposed to test in Procode not MANCODE as follows?
V = Application.Match(S, Worksheets("ProCode") _
.Range("A2:A1000"), 0)

'Use If/Else/End If test as follows:-
If IsError(V) = True Then
'Next section commented out by OssieMac
'for testing purposes. Don't know if it works
'FrmProduct.Hide
'FrmManu.Show
Else
With Me.CbxProd

'Following required if you go back
'and change selection in CbxMfg.
'If DbxProd is empty then it is ignored.
If .ListCount > 0 Then
For i = .ListCount - 1 To 0 Step -1
.RemoveItem (i)
Next i
End If

For Each J In Worksheets("ProCode").Range("A2:A1000")
If J.Text = S Then
.AddItem J(1, 2)
End If
Next J
.SetFocus
If .ListCount > 0 Then
.ListIndex = 0
End If
End With
End If

End Sub


Regards,

OssieMac
 
O

OssieMac

You indicated that the code works in your test but not when in your project.
I'll look further if you could give me a little more information.

List the objects on each form and what they do.

List what is supposed to occur throughout the project in the order that it
occurs.

What order do you show the forms etc.

Post the code that starts the process.

Regards,

OssieMac
 
M

Mekinnik

First I would like to appoligize for not answering weather the post worked or
not, I'll go back and find the ones that did work for me and answer them.
Again sorry for that.


1)FrmProduct has multible comboboxes for selecting various things which when
the user clicks the add button gets places into the sheet('ProCode'). With
the exception of CbxMan abd CbcProd all the other combobox pull the lists
from sheet('Lists') when as CbxMan get its list from sheet('MANCODE') column
'A', and then it compares the selection of CbxMan to sheet('ProCode') column
'A' and for every value/text it find in column 'A' it returns to CbxProd the
value/text of column 'B'. And this is where the problem lies it return not
the value/text of 'Procode' column 'B' but just the value/text of CbxMan List.

2) first the user selects from CboDept, then From CbxMan, then from CbxProd,
so on and so forth until all the information is added then clicks the add
button to apply the infoation to sheet('ProCode').

3) First the opening form show StrtUpFrm, then the user clicks the "Enter
Product" button, then StrtUpFrm hides, then FrmProduct shows, then if the
user types into CbxMan and it doesn't match sheet("MNACODE') colum 'A' then
FrmProduct hides and FrmManu shows and the user must enter the manufacturers
information into the database which is sheet('MANCODE'), then the
manufacturer name from FrmManu.TxtMan is transfered into CbxMan when the user
clicks next, FrmManu is hides and FrmProduct shows and the user finishes
adding the product information.
In addition you will notice I put two astricks next to a remmed out line of
code, if I activate this line I get an unspecified error for some odd reason
and again its only in the project not the test version. Thank you for your
time in looking into my problem.


The whole project starts with the folling code:

Private Sub Workbook_open()
Load StrtUpFrm
StrtUpFrm.Show 0
AppActivate Application.Caption

End Sub

Then goes into the following code:

StrtUpFrm form

Private Sub BtnClose_Click()
Unload Me
End Sub
Private Sub BtnCreate_Click()
StrtUpFrm.Hide
FrmCreate.Show
End Sub
Private Sub BtnProd_Click()
StrtUpFrm.Hide
FrmProduct.Show
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


Then it goes into the following code:

FrmProduct form

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


'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 row
Sheets("ProCode").Columns(2).Find(What:=CbxProd.Value, _
After:=Cells(5000, 2), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).EntireRow.Delete

Exit Sub
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 = ""
ender:
MsgBox "Value not found"
End Sub

Private Sub CbxMfg_Change()
Dim S As String
Dim V As Variant
Dim J As Range
S = Me.CbxMfg.Text
V = Application.Match(S, Worksheets("MANCODE").Range("A2:A1000"), 0)
If IsError(V) = True Then
FrmProduct.Hide
FrmManu.Show
End If
If IsError(V) = False Then
With Me.CbxProd
** ' .Clear
For Each J In Worksheets("ProCode").Range("A2:A1000")
If J.Text = S Then
..AddItem J(1, 2)
End If
Next J
..SetFocus
If .ListCount > 0 Then
..ListIndex = 0
End If
End With
End If
End Sub

Private Sub TxtDate_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
FrmCalendar.Show
End Sub

Private Sub UserForm_Initialize()
CbxMfg.RowSource =
Worksheets("MANCODE").Range("A2:A1000").Address(external:=True)
'CboFire.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboHealth.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboReact.RowSource =
Worksheets("Lists").Range("D2:D5").Address(external:=True)
'CboDisp.RowSource =
Worksheets("Lists").Range("E2:E4").Address(external:=True)
'CboDept.RowSource =
Worksheets("Lists").Range("C2:C10").Address(external:=True)

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Cancel = False
FrmManu.Hide
StrtUpFrm.Show
End If
End Sub


And if the user types into CbxMan FrmManu shows and it goes into the
following code then back to the previous code:

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.CbxMfg.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
FrmProduct.Show
FrmManu.Hide
End Sub

Private Sub BtnDelete_Click()

'finds manufacturer name in column 'A' _
then deletes the entire row
On Error GoTo ender
Sheets("MANCODE").Columns(1).Find(What:=TxtMan.Value, _
After:=Cells(5000, 1), LookIn:=xlFormulas, _
LookAT:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False).EntireRow.Delete
'Rows(fRow).Delete
Exit Sub

ender:
MsgBox "Value not found"
End Sub

Private Sub BtnNext_Click()
StrtUpFrm.Show
FrmManu.Hide
FrmProduct.CbxMfg.Value = Me.TxtMan.Value
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
'Cancel = False
'Else
StrtUpFrm.Show
FrmManu.Hide
End If
End Sub
 
M

Mekinnik

I would like to thank you OssieMac for looking over my code problem, but
after going over it for the millionth time I found an ovewrsite on my part
from when I was first designing the database. I had pointed the rowsource
property of both the CbxMan and CbxProd to another sheet with a row name so
no matter what code I applied it would not have worked, so I have fixed my
problem myself, again thank you for your time.
 
O

OssieMac

OK I am pleased for you that you found the problem. That is actually why I
asked for more information because I could see that the problem was not with
the specific code I checked and it had to be somewhere else.

Cheers,

OssieMac
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Coding Help for Beginner 0
Remove Identical words 0
Help with code issues 5
Match style 0
Word macro that can call cells out of Excel for a find and replace 0
Making a macro only work on certain files 2
VBA Export to PDF 0
Working outlook via vba code with xlsx - error 0

Top