VBA删除Excel中的行，如果它不包含某些值
我有一张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 试试这个来创build并填充一个新工作表。 你将不得不添加自己的代码，把它放在你想要的地方。
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