Filling a specific column based on user inputs and tracking result - excel

Question

I have range of products that are routinely tested every quarter, each product is tested once annually.
I need an excel VBA that prompts the user to input what product was tested and then prompt the user to input in which quarter (e.g. Q1,Q2 etc ) the product was tested. Then in a specific column this information about which quarter the product is tested is displayed and inputted into a cell.
I then want to be able to keep track of this information about which quarter each product was tested every year so for the next test for each product, would like excel to fill the row next to it. Shown below is an visual example of what I'm trying to achieve.
Example of Excel Worksheet
Also attached is the code I have been trying mould to fit my problem.
Dim myValue As Variant
myValue = InputBox("Give me some input")
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = myValue
Application.FindFormat.Clear
' loop through all sheets
For Each sh In ActiveWorkbook.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
Next
End Sub

Answer 1

In your code you have this line to get the product
myValue = InputBox("Give me some input")
Just add another line to get the Quarter
myValue2 = InputBox("Give me some more input")
The search command is working correctly although it could be made more efficient by restricting the search to the first column not the whole sheet.
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
To match the whole string rather than a part change the parameter LookAt:=xlWhole.
If you only have one product that matches the user input then this code can be deleted.
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
The row number is found simply with
rowno = cl.Row
The next part you seem to be having difficulty with is locating the next available
blank column in that row. The VBA is as a user would do by using Ctrl-CursorLeft
from the end column.
colno = ws.range(rowno,Columns.count).End(xlToLeft.Column +1
Since it's very unlikely your sheet will span more 702 years this might be clearer
colno = ws.range("ZZ" & rowno).End(xlToLeft).Column + 1
Now update that cell
wc.cell(rowno,colno) = Value2
Put those components together using sensible variable names, add some validation on what the user is entering, insert some debugging messages at critical points and you should get something like this ;
Sub enterdata()
Const DBUG As Boolean = False ' set to TRUE to see each step
Const YR1COL = 5 'E
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Dim sProduct As String
Dim iRowno As Long, iQu As Integer, iColno As Integer
Dim rng As Range, iLastRow As Long, wsMatch As Worksheet, cellMatch As Range
Dim chances As Integer: chances = 3
LOOP1: ' get valid product
sProduct = InputBox(Title:="Input Product", prompt:="Product is ")
If DBUG Then Debug.Print sProduct
If Len(sProduct) > 0 Then
' search through all sheets
For Each ws In wb.Sheets
iLastRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row
If DBUG Then Debug.Print ws.Name & " " & iLastRow
' Search col A of sheet using xlWhole for exact match
Set rng = ws.Range("A2:A" & iLastRow) ' avoid header
Set cellMatch = rng.Find( _
What:=sProduct, _
After:=rng.Cells(2, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
' exit on first match
If Not cellMatch Is Nothing Then
Set wsMatch = ws
GoTo LOOP2
End If
Next
Else
Exit Sub
End If
' no match so try again
If cellMatch Is Nothing Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbCritical, "Exiting"
Exit Sub
End If
MsgBox sProduct & " NOT FOUND - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP1
End If
LOOP2:
iRowno = cellMatch.Row
If DBUG Then Debug.Print wsMatch.Name & " Row = " & iRowno
' determine column
With wsMatch
iColno = .Cells(iRowno, Columns.count).End(xlToLeft).Column + 1
If iColno < YR1COL Then iColno = YR1COL ' start in E
End With
wsMatch.Activate
wsMatch.Cells(iRowno, iColno).Select
If DBUG Then
wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 6 ' yellow
Debug.Print "Column = " & iColno
End If
If DBUG Then MsgBox "Target cell " & wsMatch.Name & " Row " & iRowno & " Col " & iColno, vbInformation
chances = 3
LOOP3: ' get valid QU
iQu = Application.InputBox(Title:="Input Quarter", prompt:="Test Qu (1-4) for " & sProduct, Type:=1) ' type 1 number
If iQu = 0 Then
GoTo LOOP1
ElseIf iQu > 4 Then
chances = chances - 1
If chances < 1 Then
MsgBox "Too many tries", vbExclamation, "Error"
Exit Sub
End If
MsgBox iQu & " NOT VALID - " & chances & " tries left", vbExclamation, "Error"
GoTo LOOP3
End If
' Update sheet
wsMatch.Cells(iRowno, iColno) = iQu
If DBUG Then wsMatch.Cells(iRowno, iColno).Interior.ColorIndex = 4 ' green
MsgBox "Product=" & sProduct & vbCr _
& wsMatch.Name & " Row=" & iRowno & " Col=" & iColno & " Qu=" & iQu, vbInformation, "Updated"
GoTo LOOP1 ' next product
End Sub