根据单元格的真假从表中增加或删除行。

Question

我试图根据不同工作表中另一个表格中的单元格的值，自动在excel表格中添加删除行。

例如：在另一个表上，我有一个表，其内容如下。

在另一个表上，我有一个表，内容如下。这个表包含所有的项目，不管项目结果如何。

然后在另一个工作表上，我有一个包含所有被认为是成功的项目的表。

我试图将所有被认定为成功的项目整理到上述表格中。然而，如果我在第一张表上将Project1改为失败，Project1必须从最下面的表中删除。

我已经尝试了if语句，但我似乎无法得到正确的逻辑。这是否必须通过使用一个宏来实现？

任何帮助将是非常感激的。

Answer 1

一个VBA解决方案

• 代码会自动运行，你不需要运行任何东西。当你改变标准值时，代码会运行 (Success, Fail). 请记住，该标准是区分大小写的。

• 将以下代码复制到 片码 的源sheete.g。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