Question

我是VBA的新手，希望能得到一些帮助...我正在寻找一种简洁的方法，可以通过Macro和我尝试过的VBA示例从工作表中删除行。。我希望这很简单:)

该宏将从数组内删除不包含特定值（来自特定列）的行。我有点儿奏效了，并且完全公开了，我从其他示例中借用了代码。我正在使用的最新示例仅删除了所有内容，而我正在使用的其他示例删除了Acro32.exe，但保留了其他所有内容。因此尚未达成解决方案。

背景：我有一个来自应用程序审核工具的CSV输出，该工具会从各种计算机上吐出大量的应用程序数据。该CSV数据将被复制到我的主“报告”电子表格中。我只对查看和保存有关特定应用程序（即Chrome.exe，Firefox.exe，Acro32.exe和Winword.exe）的数据感兴趣。应用程序名称始终在F列中找到。因此，在F列中找到的所有单元格内容，即在数组中均不包含值，则需要删除整行。理想情况下：)，其余行将仅包含我对数组中定义的感兴趣的应用。

任何想法都将不胜感激。

谢谢

Public Function GetLastRow(ByVal rngToCheck As Range) As Long

    Dim rngLast As Range

    Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious)

    If rngLast Is Nothing Then
        GetLastRow = rngToCheck.Row
    Else
        GetLastRow = rngLast.Row
    End If

End Function

Sub Apps_Formatting()

    Dim varList As Variant
    Dim lngLastRow As Long, lngCounter As Long
    Dim rngToCheck As Range, rngFound As Range
    Dim rngToDelete As Range, rngDifferences As Range
    Dim blnFound As Boolean

    Application.ScreenUpdating = False

    With ActiveSheet
    lngLastRow = GetLastRow(.Cells)

        'we don't want to delete our header row
        Set rngToCheck = .Range("A2:A" & lngLastRow)
    End With

    If lngLastRow > 1 Then

        With rngToCheck

            'any Cell in Column F that contains one of these values are KEPT
            'and if not found in cell, then the entire row is deleted. 

            varList = VBA.Array("Chrome.exe", "Firefox.exe", "Acro32.exe")

            For lngCounter = LBound(varList) To UBound(varList)

                Set rngFound = .Find( _
                                        what:=varList(lngCounter), _
                                        Lookat:=xlWhole, _
                                        searchorder:=xlByRows, _
                                        searchdirection:=xlNext, _
                                        MatchCase:=True)

                'check if we found a value we want to keep
                If Not rngFound Is Nothing Then

                    blnFound = True

                    'if there are no cells with a different value then
                    'we will get an error
                    On Error Resume Next
                    Set rngDifferences = .ColumnDifferences(Comparison:=rngFound)
                    On Error GoTo 0

                    If Not rngDifferences Is Nothing Then
                        If rngToDelete Is Nothing Then
                            Set rngToDelete = rngDifferences
                        Else
                            Set rngToDelete = Application.Intersect(rngToDelete, rngDifferences)
                        End If
                    End If

                End If

            Next lngCounter
        End With

        If rngToDelete Is Nothing Then
            If Not blnFound Then rngToCheck.EntireRow.Delete
        Else
            rngToDelete.EntireRow.Delete
        End If
    End If

    Application.ScreenUpdating = True

End Sub

Answer 1

要对该线程进行跟进，如果其他人受益，则提供以下代码，并且效果很好。

Sub a1077712b()
'https://www.mrexcel.com/forum/excel-questions/1077712-vba-remove-rows-xlsx-where-particular-text-can-found-within-cell.html
Dim i As Long, r As Range
Dim va As Variant, arr As Variant, flag As Boolean
arr = Array("Chrome.exe", "Firefox.exe", "Acro32.exe", "Winword.exe")
Set r = Range("F2", Cells(Rows.count, "F").End(xlUp))
va = r

For i = 1 To UBound(va, 1)
    flag = False
        For Each x In arr
            If InStr(1, va(i, 1), x, 1) > 0 Then flag = True: Exit For
        Next
    If flag = False Then va(i, 1) = ""
Next

r = va
r.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

VBA-从XLSX中删除在单元格中可以找到特定文本的行

1 个答案: