如果Excel中不包含某些值，VBA将删除行[重复]

Question

我有一个 20 张工作簿。每张纸大约有 30,000 行带有 URL。我有一手需要保存数据的 URL（大约 10 个不同的 URL）。如果第一列（A 列 - URL）不包含其中一个 URL，有没有办法从所有工作表中删除所有行。

我有以下 vba，但它会删除所有行。如果该值与我在下面编码的内容相匹配，我需要保留该行。它还在最后抛出 424 错误（也删除所有行）。任何想法？仅查看 A 列而不是放置单元格区域的任何方式，因为它在每张工作表之间有所不同。

Sub DeleteCells()

    Dim rng As Range, i As Integer

    'Set the range to evaluate to range.
    Set rng = Range("A1:A10000")

    'Loop backwards through the rows
    'in the range that you want to evaluate.
    For i = rng.Rows.Count To 1 Step -1

        'If cell i in the range DOES NOT contains an "x", delete the entire row.
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ip/hse" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ip/hse/qhseprivate" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/crp/qhse" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/crp/qhse/csa" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/ehqhse" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/hsehw" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/lahse" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/sites/coloproposal/HSEQ AND GENERAL DOCUMENTS" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/sites/coloproposal/HSEQ AND GENERAL DOCUMENTS/LA OPERATIONS MEETING APRIL 2012" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/crp/hse" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/crp/hse/CorpQHSE" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/crp/hse/IP" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/mfg/mfg/HSE" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/mfg/mfg/HSET" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/na/HSE" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/na/HSE/er" Then rng.Cells(i).EntireRow.Delete      
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/na/HSE/GCR" Then rng.Cells(i).EntireRow.Delete     
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/na/HSE/wr" Then rng.Cells(i).EntireRow.Delete
        If rng.Cells(i).Value <> "https://inside.nov.pvt/ops/mexopex" Then rng.Cells(i).EntireRow.Delete        
    Next

End Sub

Answer 1

试试这个来创建和填充一个新的工作表。您必须添加自己的代码才能将其放在您想要的位置。

Sub saveImportantData()
    Dim myUrlArray, oldSheetRowArray, arrayCounter As Long
    Dim tempWS As Worksheet, myWS As Worksheet, newSheetRowCounter As Long

    ReDim oldSheetRowArray(1 To 1)
    Set myWS = ActiveSheet
    Set tempWS = Sheets.Add(After:=Sheets(Worksheets.Count))

    newSheetRowCounter = 1
    arrayCounter = 1
    myUrlArray = Array("https://inside.nov.pvt/ip/hse", _
                    "https://inside.nov.pvt/ip/hse/qhseprivate", _
                    "https://inside.nov.pvt/crp/qhse", _
                    "https://inside.nov.pvt/crp/qhse/csa", _
                    "https://inside.nov.pvt/crp/qhse/csa", _
                    "https://inside.nov.pvt/ops/ehqhse", _
                    "https://inside.nov.pvt/ops/hsehw", _
                    "https://inside.nov.pvt/ops/lahse", _
                    "https://inside.nov.pvt/sites/coloproposal/HSEQ AND GENERAL DOCUMENTS", _
                    "https://inside.nov.pvt/sites/coloproposal/HSEQ AND GENERAL DOCUMENTS/LA OPERATIONS MEETING APRIL 2012", _
                    "https://inside.nov.pvt/crp/hse", _
                    "https://inside.nov.pvt/crp/hse/CorpQHSE", _
                    "https://inside.nov.pvt/crp/hse/IP", _
                    "https://inside.nov.pvt/mfg/mfg/HSE", _
                    "https://inside.nov.pvt/mfg/mfg/HSET", _
                    "https://inside.nov.pvt/ops/na/HSE", _
                    "https://inside.nov.pvt/ops/na/HSE/er", _
                    "https://inside.nov.pvt/ops/na/HSE/GCR", _
                    "https://inside.nov.pvt/ops/na/HSE/wr", _
                    "https://inside.nov.pvt/ops/mexopex")

    For i = 1 To UBound(myUrlArray)
       With myWS.Range("A1:A10000")
        Set c = .Find(myUrlArray(i), LookIn:=xlValues)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    oldSheetRowArray(arrayCounter) = c.Row
                    arrayCounter = arrayCounter + 1
                    ReDim Preserve oldSheetRowArray(1 To arrayCounter)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    Next i


    Application.ScreenUpdating = False
    For k = 1 To UBound(oldSheetRowArray)
        If oldSheetRowArray(k) <> "" Then
            myWS.Activate
            myWS.Rows(oldSheetRowArray(k) & ":" & oldSheetRowArray(k)).Select
            Selection.Copy
            tempWS.Activate
            tempWS.Range("A" & newSheetRowCounter).Select
            ActiveSheet.Paste
            newSheetRowCounter = newSheetRowCounter + 1
        End If
    Next k
    Application.ScreenUpdating = True

    Set myWS = Nothing
    Set tempWS = Nothing
    Set c = Nothing

End Sub