Calling an additional sub

[Aussiebear]

In the following code I wanted to call an additional sub to place the test number and its related result against a client onto the TestHistory sheet. Currently as the code is, it doesn't do this.

Sub AddTestHistory(Target As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory
Set Tgt = .Cells(.Clumns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = MetxtVendorTest.Text
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
End With

End Sub


This code forms part of a sequence of "calls". The data is entered via a form "RiskLevels" which is designed to initailly place the same data into the "Risk Levels" Sheet, then place data into the "Whiteboard" sheet and finally into the "TestHistory" Sheet. I have for the sake of minimising the upload stripped all data from the workbook. Password to view code is "Shona".

Should it be necessary to provide another workbook with some data added I am happy to do so.

Full code for the form is as follows;

Option Explicit
Private Sub cmdAdd_Click()
Dim Tgt As Range, Col As Long
Dim Grower As String
Dim Vendor As String
Dim Result As String

On Error Resume Next

Grower = Me.txtGrowerID.Text
Vendor = Me.txtVendorTest.Text
Result = Me.cboResult.Text

' Check for a Grower ID
If Trim(Me.txtGrowerID.Text) = "" Then
Me.txtGrowerID.SetFocus
MsgBox "Please Enter a Grower ID"
Exit Sub
End If

'Get Row Number
With RiskLevels
Set Tgt = .Cells(.Columns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
End With

' Determine the position for the new data to be added
Call CheckforBlanks(Tgt, Vendor, Result)

'Adjust the risk level status if necessary on the Risk Level sheet
Call AdjustRiskLevels(Tgt)

' Update the Vendors Test on the Whiteboard Sheet
Call UpdateWhiteboard(Tgt, Result, Vendor)

' Call UpdateTestHistory(Tgt, Vendor, Result)
Call AddTestHistory(Tgt, Result, Vendor)
' Clear data from form after having written to sheet
Me.txtGrowerID.Value = ""
Me.txtVendorTest.Value = ""
Me.cboResult.Value = ""
Me.lblGrower.Caption = ""
Me.txtGrowerID.SetFocus
'
End Sub
Sub CheckforBlanks(Tgt As Range, Vendor As String, Result As String)
Dim Col As Long
'Check for Blanks
Col = Application.WorksheetFunction.CountBlank(Tgt.Range("J1:L1"))
Select Case Col
Case 0
Tgt.Range("K1:L2").Cut Tgt.Range("J1")
Tgt.Range("L1") = Vendor
Tgt.Range("L2") = Result
Case 1
Tgt.Range("L1") = Vendor
Tgt.Range("L2") = Result
Case 2
Tgt.Range("K1") = Vendor
Tgt.Range("K2") = Result
Case 3
Tgt.Range("J1") = Vendor
Tgt.Range("J2") = Result
End Select
End Sub

Sub AdjustRiskLevels(Tgt As Range)
Dim Col As Long
'Adjust risk level value for result
Col = Application.WorksheetFunction.CountBlank(Tgt.Range("J1:L1"))
Select Case Me.cboResult

Case ">MRL"
Tgt.Range("M1") = 3

Case "<AL", ">AL"
If Tgt.Range("M1") = 0 Then Tgt.Range("M1") = 1
If Tgt.Range("M1") < 3 Then Tgt.Range("M1") = Tgt.Range("I1")
If Tgt.Range("M1") = 3 Then Tgt.Range("M1") = 3


Case "<LOR"
If Tgt.Range("M1") = 0 Then
'No Change
Else
Select Case Col
Case Is < 2
If Tgt.Range("K2") = "<LOR" And Tgt.Range("L2") = "<LOR" Then
If Tgt.Range("M1") < 3 Then Tgt.Range("M1") = 0
If Tgt.Range("M1") = 3 Then Tgt.Range("M1") = Tgt.Range("I1")
End If
Case 2
If Tgt.Range("J2") = "<LOR" And Tgt.Range("K2") = "<LOR" Then
If Tgt.Range("M1") < 3 Then Tgt.Range("M1") = 0
If Tgt.Range("M1") = 3 Then Tgt.Range("M1") = Tgt.Range("I1")
End If
'Case 2
' No Change
'Case 3
' No Change
End Select
End If
End Select

End Sub

Sub AddTestHistory(Target As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory
Set Tgt = .Cells(.Clumns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = MetxtVendorTest.Text
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
End With

End Sub



Private Sub txtGrowerID_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim c As Range
Set c = RiskLevels.Columns(2).Find(txtGrowerID)
If c Is Nothing Then
MsgBox "Please check ID number"
Cancel = True
txtGrowerID = ""
End If
End Sub

Private Sub txtGrowerID_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim c As Range
Set c = RiskLevels.Columns(2).Find(txtGrowerID)
lblGrower.Caption = c.Offset(, -1)
ActiveWindow.ScrollRow = c.Row
End Sub

Private Sub txtVendorTest_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim c As Range
Set c = RiskLevels.Columns("J:L").Find(txtVendorTest.Text)
If Not c Is Nothing Then
MsgBox "Test No. exists in Cell " & c.Address(0, 0)
On Error GoTo 0
'Clear data from form and reset focus to GrowerID
Me.txtGrowerID.Value = ""
Me.lblGrower.Caption = ""
Me.txtVendorTest.Value = ""
Me.txtGrowerID.SetFocus
End If

End Sub

Private Function GetColumn(ByVal Key As String)
Select Case Key
Case "01", "01R": GetColumn = "K"
Case "250", "250R": GetColumn = "M"
Case "500", "500R": GetColumn = "O"
Case "1000", "1000R": GetColumn = "Q"
Case "1500", "1500R": GetColumn = "S"
Case "2000", "2000R": GetColumn = "U"
End Select
End Function

Private Sub UpdateWhiteboard(Tgt As Range, Result As String, Vendor As String)
Dim ColLetter As String

'Get Row Number
With Whiteboard
Set Tgt = .Columns(2).Find(What:=Left(Vendor, 8), Lookat:=xlWhole)
End With
Whiteboard.Range(GetColumn(Right(Vendor, Len(Vendor) - 9)) & Tgt.Row).Value = Result

End Sub

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub UpdateTestHistory(Tgt, Vendor As String, Result As String)

'Set the sheet to Test History
With TestHistory

'Find the correct row (Vendor)to insert the data
Set Tgt = .Columns(1).Find(What:=Left(Vendor, 1), Lookat:=xlWhole)
End With

'Copy the Test Number to the next blank column of the correct row
TestHistory.Range(GetColumn(Right(Vendor, Len(Vendor) - 9)) & Tgt.Row).Value = Result

End Sub

[Bob Phillips]

No workbook




Sub AddTestHistory(Target As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory
Set Tgt = .Cells(.Clumns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
'>>> why do you find this when you have passed the value as the Target parameter
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = MetxtVendorTest.Text
'>>> you are missing the dot after Me
'>>> why do you get the form value when you have passed the value as the Vendor parameter
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
'>>> why do you get the form value when you have passed the value as the Result parameter
End With

End Sub

[Aussiebear]

I have been using the initial code as a Private Sub to compile a seperate workbook to suit a management request. They wanted to see the full test history of each vendor. Once that was done I then added the data to the GSRT workbook as a sheet. From that I thought that i could simply make this a sub to be called based on similar subs being called from the form that I use to enter the data in the GSRT workbook.

Sadly I'll have to strip a working copy down to fit the upload restrictions. (Which will have to wait util tonight)

[Aussiebear]

Workbook Available for perusal

[Aussiebear]

No workbook




Sub AddTestHistory(Target As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory
Set Tgt = .Cells(.Clumns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
'>>> why do you find this when you have passed the value as the Target parameter
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = MetxtVendorTest.Text
'>>> you are missing the dot after Me
'>>> why do you get the form value when you have passed the value as the Vendor parameter
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
'>>> why do you get the form value when you have passed the value as the Result parameter
End With

End Sub


Okay I'm now really confused. XLD, do you want to explain this in greater detail please.

[Bob Phillips]

I'm confused Ted, what eaxctly is/is not happening here. I thougt the call wasn't happening, but I cannot see that Call in the code.

[Bob Phillips]

Okay I'm now really confused. XLD, do you want to explain this in greater detail please.

WhatI was saying Ted is that most of this routine seems superflous to me



Sub AddTestHistory(Target As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory
Set Tgt = .Cells(.Clumns(2).Find(What:=Grower, Lookat:=xlWhole).Row, 1)
'>>> there seems no need to do this Find as the caller proceduer did a Find and passed _
the result as Target



LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = MetxtVendorTest.Text
'>>> you are missing the dot after Me - a simple syntax error but maybe a problem for you

'>>> but again, why do you get the form value. The caller procedure got it and passed it _
as the Vendor parameter



.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
'>>> and yet again, why do you get the form value. The caller procedure got it and passed it _
as the Result parameter



End With

End Sub

[Aussiebear]

Bob, in the attached workbook, I used a form to enter all the results for every Vendor. The code worked there. Management wanted to see the full test results contained as a sheet within the the GSRT workbook.

Since most of the code already existed within both workbooks, I tried to transfer what I thought was a relevant section ( as a sub). Where i've made a mistake is that I was trying to remember what the code was, since it was a work (50 klms away). If I've mislead you then I apologise. This was the code I used. The 15 hour days are starting to wear me out and I'm getting too tired to really concentrate on code.


Private Sub cmdAdd_Click()
Dim Tgt As Range, Col As Long
Dim Grower As String
Dim Vendor As String
Dim Result As String
Dim LastCol As Long

On Error Resume Next

Grower = Me.txtGrowerID.Text
Vendor = Me.txtVendorTest.Text
Result = Me.cboResult.Text

' Check for a Grower ID
If Trim(Me.txtGrowerID.Text) = "" Then
Me.txtGrowerID.SetFocus
MsgBox "Please Enter a Grower ID"
Exit Sub
End If

With TestHistory
Set Tgt = .Cells(.Columns(2).Find(What:=Grower, lookat:=xlWhole).Row, 1)
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = Me.txtVendorTest.Text
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
End With

' Clear data from form after having written to sheet
Me.txtGrowerID.Value = ""
Me.txtVendorTest.Value = ""
Me.cboResult.Value = ""
Me.lblGrower.Caption = ""
Me.txtGrowerID.SetFocus
'
End Sub

From all that I reduced it to this and added it to the form "RiskLevel" to be called

Private Sub UpdateTestHistory(Tgt As Range, Result As String, Vendor As String)
Dim Col As Long
Dim Grower As String
Dim LastCol As Long
Dim TestHistory As Worksheet

On Error Resume Next

With TestHistory

Set Tgt = .Cells(.Columns(2).Find(What:=Grower, lookat:=xlWhole).Row, 1)
LastCol = .Cells(Tgt.Row, .Columns.Count).End(xlToLeft).Column
.Cells(Tgt.Row, LastCol + 1).Value = Me.txtVendorTest.Text
.Cells(Tgt.Row + 1, LastCol + 1).Value = Me.cboResult.Value
End With

End Sub

I was hoping to "call" the sub as part of the 4 part "Call" process

Private Sub cmdAdd_Click()
Dim Tgt As Range, Col As Long
Dim Grower As String
Dim Vendor As String
Dim Result As String
Dim RiskLevels As Worksheet
Dim TestHistory As Worksheet
Dim LastCol As Long
On Error Resume Next

Grower = Me.txtGrowerID.Text
Vendor = Me.txtVendorTest.Text
Result = Me.cboResult.Text

' Check for a Grower ID
If Trim(Me.txtGrowerID.Text) = "" Then
Me.txtGrowerID.SetFocus
MsgBox "Please Enter a Grower ID"
Exit Sub
End If

'Get Row Number
With RiskLevels
Set Tgt = .Cells(.Columns(2).Find(What:=Grower, lookat:=xlWhole).Row, 1)
End With

' Check for Blanks on Risk Level Sheet
Call CheckforBlanks(Tgt, Vendor, Result)
' Adjust Risk level Values on Risk Level Sheet
Call AdjustRiskLevels(Tgt)
' Update the Test Result value of the Vendor on the Whiteboard page
Call UpdateWhiteboard(Tgt, Result, Vendor)
' Update the Vendor's Test History on the Test History sheet
Call UpdateTestHistory(Tgt, Result, Vendor)


' Clear data from form after having written to sheet
Me.txtGrowerID.Value = ""
Me.txtVendorTest.Value = ""
Me.cboResult.Value = ""
Me.lblGrower.Caption = ""
Me.txtGrowerID.SetFocus
'
End Sub

What is happening is that the values from the form are being placed into the correct position on the Risk Levels Sheet, but then the code no longer updates the Whiteboard sheet, not does it update the Test History sheet.

I would like to be able to post my GSRT workbook for the forum members to look at, but its oversized, even when zipped. Tonight I have to rush off to Brisbane so i can attend an all day seminar tomorrow. I fear I shall embarrass myself by falling asleep during the lectures.