Question

我是VBA的新手，我正在尽力解释我想做什么

我需要查看表1和表2 如果他们有价值＆＃34; AAA＆＃34;或＆＃34; BBB＆＃34;或者＆＃34; CCC＆＃34;在排，我想保留它，如果没有，删除整行

我的下面的代码只能帮助我删除行，除了它包含＆＃34; AAA＆＃34;在Q栏中

我不知道如何添加更多价值，例如＆＃34; BBB＆＃34; ＆安培; ＆＃34; CCC＆＃34;，如果该行有这些值，或者一个，我想保留它



如何添加更多列进行检查？现在只检查Q列，如果我想从H列检查到R？



我实际上有10个值（AAA，BBB，CCC .... JJJ）要保留，我是否需要逐个输入，或者有一个方法可以询问excel   检查列表，如果Sheet 1和Sheet 2中的任何单元格与any匹配   一个来自这10个值，保留行，否则，删除整个   行

该列表位于第A1栏的第3页：A10

谢谢！我的代码如下

Sub RemoveCell()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With


With Sheets("Sheet1")


    .Select


    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    .DisplayPageBreaks = False

    'Set the first and last row to loop through
    Firstrow = .UsedRange.Cells(1).Row
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    'loop from Lastrow to Firstrow (bottom to top)
    For Lrow = Lastrow To Firstrow Step -1

        With .Cells(Lrow, "Q")

            If Not IsError(.Value) Then

                If .Value <> "AAA" Then .EntireRow.Delete


            End If

        End With

    Next Lrow

End With

ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .Calculation = CalcMode
End With

End Sub

Answer 1

您可以尝试使用数组来检查您要查找的值是否存在。 sub＆＃34; FillArray＆＃34;使用工作表3中的数据填充数组。如果添加更多值，则可以更改范围，或者更改代码以动态检查数组的大小。代码：

   Dim arr(9) As Variant

Sub RemoveCell()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim colsTocheck As Integer

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
Call FillArray
With Sheets("Sheet1")
    .Select
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    .DisplayPageBreaks = False

    'Set the first and last row to loop through
        Firstrow = .UsedRange.Cells(1).Row
        Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

        'loop from Lastrow to Firstrow (bottom to top)
        For Lrow = Lastrow To Firstrow Step -1
        deleteRow = False
            For colsTocheck = 8 To 18 '8 is H 18 is R - i find it easier to use column numbers
                With .Cells(Lrow, colsTocheck)
                    If IsError(.Value) = False And .Value <> "" Then
                        If IsInArray(.Value, arr) Then
                            deleteRow = False
                            Exit For
                        Else
                        deleteRow = True
                        End If

                    End If
                End With
            Next colsTocheck

            If deleteRow Then .Cells(Lrow, colsTocheck).EntireRow.Delete

        Next Lrow

End With

ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .Calculation = CalcMode
End With

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean 'chceck if value is in array
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Sub FillArray() 'fill array with values to check against
    Dim sList As Worksheet
    Set sList = Sheets("Sheet3")

    For i = 0 To 9
        arr(i) = sList.Cells(i + 1, 1)
    Next i
End Sub

Answer 2

在这里，你只需像这样使用：

Sub Test_CheL()
    '''Tune the parameters to fit your need : Sheet1 and AAA/BBB/CCC/JJJ
    Call DeleteRowsNotContaining(ThisWorkbook.Sheets("Sheet1"), "AAA/BBB/CCC/JJJ")
End Sub

我添加了一些改善性能和稳定性的方法：

EnableEvents = False，
删除行后重新显示PageBreaks，
少量Exit For以避免在有足够的时间继续循环
将单元格的值存储到变量中，以在针对数组值

删除列表中不包含任何值的行的代码：

Sub DeleteRowsNotContaining(wS As Worksheet, ValuesToKeep As String)
Dim FirstRow As Long
Dim LastRow As Long
Dim LastColInRow As Long
Dim LoopRow As Long
Dim CalcMode As Long
Dim ViewMode As Long

Dim VtK() As String
Dim i As Integer
Dim KeepRow As Boolean
Dim CelRg As Range
Dim CelStr As String

With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

VtK = Split(ValuesToKeep, "/")

With wS
    .Select
    ViewMode = ActiveWindow.View
    ActiveWindow.View = xlNormalView
    .DisplayPageBreaks = False

    '''Set the first and last row to loop through
    FirstRow = .UsedRange.Cells(1, 1).Row
    LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    '''Loop from Lastrow to Firstrow (bottom to top)
    For LoopRow = LastRow To FirstRow Step -1
        '''If you don't find any of your values, delete the row
        KeepRow = False
        LastColInRow = .Cells(LoopRow, .Columns.Count).End(xlToLeft).Column

        With .Range(.Cells(LoopRow, "A"), .Cells(LoopRow, LastColInRow))
            For Each CelRg In .Cells
                '''If cell contains an error, go directly to the next cell
                If IsError(CelRg.Value) Then
                Else
                    CelStr = CStr(CelRg.Value)
                    For i = LBound(VtK) To UBound(VtK)
                        If CelStr <> VtK(i) Then
                        Else
                            '''Cell contains a value to keep
                            KeepRow = True
                            Exit For
                        End If
                    Next i
                    '''If you already found a value you want to keep, go next line
                    If KeepRow Then Exit For
                End If
            Next CelRg
            '''Check if you need to delete the row
            If Not KeepRow Then .EntireRow.Delete
        End With '.Range(.Cells(LoopRow, "A"), .Cells(LoopRow, LastColInRow))
    Next LoopRow
    .DisplayPageBreaks = True
End With 'wS

ActiveWindow.View = ViewMode
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With
End Sub

Excel - 如果不包含列表

2 个答案: