Добавление / удаление строк из таблицы в зависимости от истинной или ложной ячейки

Question

Я пытаюсь автоматически добавлять / удалять строки в таблицу в Excel в зависимости от значения ячейки в другой таблице на другом листе.

Например;

На отдельном лист у меня есть одна таблица со следующим. Эта таблица содержит все проекты независимо от результатов проекта.

А затем на другом листе у меня есть таблица, содержащая все записи, которые были признаны успешными .

Я пытаюсь сопоставить все проекты, которые были определены как успешные, в приведенной выше таблице. Однако, если бы я должен был изменить Project1 на Fail в первой таблице, Project1 должен быть удален из нижней таблицы.

Я пробовал операторы if, но, похоже, не могу правильно получить logi c. Должно ли это быть достигнуто с помощью макроса?

Любая помощь будет принята с благодарностью.

Answer 1

Решение VBA

• Код запускается автоматически, вам не нужно ничего запускать. Код будет запускаться при изменении значений критериев (Success, Fail). Имейте в виду, что критерии чувствительны к регистру.

• Скопируйте следующий код в код листа исходного листа, например Sheet1, и тщательно настройте 5 констант. в соответствии с вашими потребностями.

Код листа

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Const FirstRow As Long = 2            ' Source/Target First Row Number
    Const Cols As String = "A:G"          ' Source/Target Columns Range Address
    Const CritCol As Long = 4             ' Criteria Column
    ' Note: If CritCol = n then it presents the n-th column of Columns Range,
    '       and not the n-th column of the worksheet.
    Const Criteria = "Success"            ' Criteria
    Const TargetName = "Sheet2"           ' Target Worksheet Name

    Dim SourceColumns As Range
    Set SourceColumns = Me.Columns(Cols)
    Dim CriteriaColumn As Long
    CriteriaColumn = getNthColumn(Me, SourceColumns.Address, CritCol)

    If CriteriaColumn = 0 Then Exit Sub
    If Intersect(Me.Columns(CriteriaColumn), Target) Is Nothing Then Exit Sub

    Dim CriteriaRange As Range
    Set CriteriaRange = getColumnRange(Me, CriteriaColumn, FirstRow)

    If Not Intersect(CriteriaRange, Target) Is Nothing Then
        Dim TargetSheet As Worksheet
        Set TargetSheet = ThisWorkbook.Worksheets(TargetName)
        Call transferData(SourceColumns, CriteriaRange, CritCol, Criteria, _
                             FirstRow, TargetSheet)
    End If

End Sub

• Скопируйте следующий код в стандартный модуль, например Module1. Здесь нечего менять.

Код модуля

Option Explicit

Function getColumnRange(Sheet As Worksheet, _
                        ByVal ColumnNumberOrLetter As Variant, _
                        Optional ByVal FirstRow As Long = 1) As Range
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnNumberOrLetter) _
        .Find("*", , xlFormulas, , , xlPrevious)
    If rng Is Nothing Then Exit Function      ' No data in whole column.
    If rng.Row < FirstRow Then Exit Function  ' No data in and below first cell.
    Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRow, rng.Column), rng)
End Function

Function getNthColumn(Sheet As Worksheet, ByVal RangeAddress As String, _
                      Optional ByVal NthColumn As Long = 1) As Long
    Dim rng As Range
    Set rng = Sheet.Columns(RangeAddress)
    If rng Is Nothing Then Exit Function
    If rng.Columns.Count < NthColumn Then Exit Function
    getNthColumn = rng.Column + NthColumn - 1
End Function

Sub transferData(SourceColumns As Range, CriteriaColumnRange As Range, _
  CriteriaColumn As Long, Criteria As Variant, FirstRow As Long, _
  TargetSheet As Worksheet)

    Dim NoR As Long
    NoR = Application.WorksheetFunction.CountIf(CriteriaColumnRange, Criteria)
    Dim Source As Variant
    Source = Intersect(SourceColumns, CriteriaColumnRange.Rows.EntireRow)

    Dim Target As Variant
    Dim i As Long, j As Long, k As Long
    ReDim Target(1 To NoR, 1 To UBound(Source, 2))
    For i = 1 To UBound(Source)
        If Source(i, CriteriaColumn) = Criteria Then
            k = k + 1
            For j = 1 To UBound(Source, 2)
                Target(k, j) = Source(i, j)
            Next j
        End If
    Next i
    Erase Source

    With TargetSheet
        .Range(SourceColumns.Rows(FirstRow).Address).Resize( _
          .Rows.Count - FirstRow + 1).ClearContents
        .Range(SourceColumns.Rows(FirstRow).Address).Resize(k) = Target
    End With

End Sub