Aussiebear
02-19-2008, 03:54 AM
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
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