Блог

Моя лаборатория способна выполнять более 20 различных анализов, и мы получаем контракты примерно от тех же 15 компаний на выполнение комбинации этих анализов. Я создал таблицу Excel, чтобы отслеживать работу по мере ее поступления, где столбцы представляют собой 20 различных анализов, которые мы можем выполнить, а строки — компании. Я ввожу либо галочку, либо «NA», в зависимости от того, запрашивает ли эта компания этот конкретный анализ. (Каждая компания запрашивает свою собственную комбинацию анализов).

Мне нужна помощь в следующем:

Если я ввожу «Company 1» в ячейку A100, я хочу, чтобы в ячейке B100 отображалось «NA». Если вместо этого я введу «Company 2», я хочу, чтобы в ячейке D100 отображалось «NA». И если я введу «Company 3», ничего не делайте, например. Я согласен с добавлением флажков вручную, поскольку есть другие переменные, которые не нужно упоминать.

Теперь я смог в некоторой степени разработать какое-то игрушечное решение на VBA (см. Код ниже). Однако у меня есть две проблемы:

1. Чтобы запустить код, я должен переключиться на редактор VBA и нажимать F5 после каждой записи. Вместо этого я хотел бы, чтобы это работало так же, как при использовании формул для ячеек. Другими словами, если я введу «Company 1» в любую ячейку столбца A и нажму «Enter», я бы хотел, чтобы «NA» автоматически отображался в соответствующих ячейках строки. Думаю, я мог бы записать для этого макрос, но файл доступен многим людям, и я бы предпочел этого избежать.
2. В будущем мне нужно будет добавить больше компаний и анализов, поэтому мне нужен код, который я могу быстро ввести и обновить. Или, может быть, у вас есть список компаний, в которые я добавляю, и как-то связать его с моим кодом.

    Sub writeNA()
   For i = 1 To 20 Step 1
   
   x = Cells(i, 1).Value
   
   If x = "Company 1" Then
    Cells(i, 2).Value = "NA"
   End If
   
   If x = "Company 2" Then
    Cells(i, 3).Value = "NA"
   End If
   
   If x = "Company 3" Then
    Cells(i, 4).Value = "NA"
   End If
   
   Next
   End Sub
    

Спасибо!

Вы могли бы добавить обработчик событий изменения листа, чтобы при каждом изменении листа запускалась функция и добавляла «NA» там, где это необходимо.

Вот функция, которую я использовал для проверки концепции. Он также добавляет «NA» при вводе «Company 3» (не уверен, желательно это или нет).

 Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Text
    Case "Company 1", "Company 2", "Company 3"
    Target.Offset(0, 1).Cells.Value2 = "NA"
End Select
End Sub
 

Обновление ячеек при вводе значений (событие изменения листа)

• Обычно код приходится копировать в разные модули (если вы хотите использовать его на нескольких рабочих листах). При желании вы можете скопировать оба кода в модуль sheet.
• Отрегулируйте значения в разделе константы.
• Ничего запускать не нужно, все выполняется автоматически.
• Если у вас уже есть значения в Criteria Column , тогда сделайте a copy/paste , и данные будут обновлены.

Модуль листа, например Sheet1

 Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    updateCompany Me, Target
End Sub
 

Стандартный модуль, например Module1

 Option Explicit

Sub updateCompany( _
        ws As Worksheet, _
        Target As Range)
        
    Const ProcName As String = ""
    On Error GoTo clearError

    Const CompanyList As String = "Company 1,Company 2,Company 3"
    Const ColsList As String = "B,D,"
    Const CriteriaList As String = "NA,NA,"
    Const FirstRow As Long = 2
    Const CritCol As String = "A"
    
    Dim cel As Range
    Dim rng As Range
    
    ' Define Processing Range (First Cell to Bottom-Most Cell (1048576)).
    Set rng = ws.Columns(CritCol) _
        .Resize(ws.Rows.Count - FirstRow   1) _
        .Offset(FirstRow - 1)
    
    ' Define Last Non-Empty Cell.
    Set cel = rng.Find( _
        What:="*", _
        LookIn:=xlFormulas, _
        SearchDirection:=xlPrevious)
    ' Validate Last Non-Empty Cell
    ' i.e. check if Processing Range contains a value.
    If cel Is Nothing Then
        GoTo ProcExit
    End If
    
    ' Define Source Range (First Cell to Last Non-Empty Cell).
    Set rng = rng.Resize(cel.Row - rng.Row   1)
    
    ' Define Target Range.
    Set rng = Intersect(Target, rng)
    ' Validate Target Range i.e. check if the change happened in Source Range.
    If rng Is Nothing Then
        GoTo ProcExit ' Change didn't happen in Source Range.
    End If
    
    ' Write values from Company List to Company Array.
    Dim Company() As String: Company = Split(CompanyList, ",")
    ' Write values from Columns List to Columns Array.
    Dim Cols() As String: Cols = Split(ColsList, ",")
    ' Write values from Criteria List to Criteria Array.
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    
    Application.EnableEvents = False
    
    ' Write values to cells in rows of changed cells.

    Dim CurrentMatch As Variant
    ' Loop through cells of Target Range (can be non-contiguous).
    For Each cel In rng.Cells
        ' Check if current cell is not blank (Empty or "").
        If Len(cel.Value) > 0 Then
            ' Try to find the value in current cell (Company) in Company Array.
            CurrentMatch = Application.Match(cel.Value, Company, 0)
            ' If found...
            If IsNumeric(CurrentMatch) Then
                ' Define the current index of the found value.
                CurrentMatch = CurrentMatch - 1 ' -1 because 0-based.
                ' Check if the value in Columns Array is different than "".
                If Cols(CurrentMatch) <> "" Then
                    ' Write value from Criteria Array to cell in current row
                    ' of the column found in Columns Array.
                    Cells(cel.Row, Cols(CurrentMatch)) = Criteria(CurrentMatch)
                Else
                    ' The value in Columns Array is "".
                End If
            Else
                ' Couldn't find Company name in Company Array.
            End If
        Else
            ' Cell is blank or empty.
        End If
    Next cel

SafeExit:
    Application.EnableEvents = True

ProcExit:
    Exit Sub

clearError:
    Debug.Print "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "        " amp; Err.Description
    Resume SafeExit

End Sub