VBA 특정 값이 포함되어 있지 않은 Excel에서 행을 삭제하려면

Question

20 개의 시트가있는 통합 문서가 있습니다. 각 시트에는 URL이있는 약 30,000 개의 행이 있습니다. 데이터를 보관할 필요가있는 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