Заполнение указанного столбца c на основе пользовательских данных и результатов отслеживания

Question

У меня есть ряд продуктов, которые регулярно тестируются каждый квартал, каждый продукт тестируется один раз в год.

Мне нужен Excel VBA, который предлагает пользователю ввести, какой продукт был протестирован, а затем предлагает пользователю ввести в каком квартале (например, Q1, Q2 et c) продукт был протестирован. Затем в определенном столбце c эта информация о том, в каком квартале тестируется продукт, отображается и вводится в ячейку.

Затем я хочу иметь возможность отслеживать эту информацию о том, в каком квартале тестировался каждый продукт. каждый год, поэтому для следующего теста для каждого продукта, хотелось бы, чтобы Excel заполнял строку рядом с ним. Ниже показан наглядный пример того, чего я пытаюсь достичь.

Пример рабочего листа Excel

Также приложен код, который я пытался создать чтобы соответствовать моей проблеме.

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

В вашем коде у вас есть эта строка для получения продукта

myValue = InputBox("Give me some input")

Просто добавьте еще одну строку, чтобы получить Quarter

myValue2 = InputBox("Give me some more input")

Команда поиска работает правильно, хотя это может быть стало более эффективным, ограничив поиск первым столбцом, а не целым листом.

Set cl = sh.Cells.Find(What:=SearchString, _
   After:=sh.Cells(1, 1), _
   LookIn:=xlValues, _
   LookAt:=xlPart, _
   SearchOrder:=xlByRows, _
   SearchDirection:=xlNext, _
   MatchCase:=False, _
   SearchFormat:=False)

Чтобы сопоставить всю строку, а не часть, измените параметр LookAt: = xlWhole.

Если у вас есть только один продукт, который соответствует пользовательскому вводу, этот код можно удалить.

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

Номер строки можно найти просто с помощью

rowno = cl.Row

. следующая часть, с которой у вас возникли проблемы, - это поиск следующего доступного пустого столбца в этой строке. VBA - это то же самое, что и пользователь, используя Ctrl-CursorLeft из конечного столбца.

colno = ws.range(rowno,Columns.count).End(xlToLeft.Column +1

Поскольку маловероятно, что ваш лист будет охватывать более 702 лет, это может быть яснее

colno = ws.range("ZZ" & rowno).End(xlToLeft).Column + 1

Теперь обновите эту ячейку

wc.cell(rowno,colno) = Value2

Соедините эти компоненты, используя разумные имена переменных, добавьте некоторую проверку того, что вводит пользователь, вставьте несколько сообщений отладки в критических точках, и вы должны получить что-то вроде этого;

  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