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

如果VBA不包含某些值，则VBA将删除Excel中的行

1 个答案: