VBA to Delete Table Rows Based on Two Columns

[nirvehex]

Hello All,

I'm trying to write some VBA code that deletes table rows based on data in two columns. The two columns have Headers "LocationCode" and "ServiceType" in my Table, which is "Table2".

What I'm trying to do is look at all like values in the "LocationCode" column and see if there is a row under the "ServiceType" column that has an "H".

If it DOES NOT have an "H" under ServiceType for that LocationCode I want to delete the row.

For example, in the below table, all of the "Loc00002" rows would get deleted because there is no corresponding "H" in the ServiceType column. The other two locations, no lines would get deleted. Any ideas how to code this? Thank you!!

LocationCode	ServiceType
Loc000001	H
Loc000001	Z
Loc000001	TST
Loc00002	CCS
Loc00002	ROC
Loc0000003	H
Loc0000003	H

 

[Domenic]

Try the following macro...

Option Explicit

Sub Delete_Non_H_Locations()

    'create a dictionary object to hold unique location codes
    Dim locationsDictionary As Object
    Set locationsDictionary = CreateObject("Scripting.Dictionary")
    
    'set dictionary to case-insensitive comparison mode
    locationsDictionary.comparemode = 1 'vbTextCompare
    
    'set the source table (change the sheet name accordingly)
    Dim sourceTable As ListObject
    Set sourceTable = Worksheets("Sheet1").ListObjects("Table2")
    
    'if source table is filtered, clear any and all filters
    With sourceTable
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
    
    'loop through each cell in LocationCode column and fill dictionary with unique location codes
    Dim currentCell As Range
    For Each currentCell In sourceTable.ListColumns("LocationCode").DataBodyRange
        locationsDictionary(currentCell.Value) = ""
    Next currentCell
    
    'filter source table for each unique location, and delete all rows if it doesn't have a service type "H"
    With sourceTable
        Dim currentKey As Variant
        For Each currentKey In locationsDictionary
            .Range.AutoFilter field:=.ListColumns("LocationCode").Index, Criteria1:=currentKey
            If Application.CountIf(.ListColumns("ServiceType").DataBodyRange.SpecialCells(xlCellTypeVisible), "H") = 0 Then
                With .Range
                    .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
            End If
        Next currentKey
        .AutoFilter.ShowAllData
    End With
    
End Sub

Hope this helps!

 

[DanteAmor]

Here is another macro for you to consider

Sub test()
  Dim dic As Object, i As Long, m As Variant, tbl As ListObject
  
  Set dic = CreateObject("scripting.dictionary")
  Set tbl = ActiveSheet.ListObjects("Table2")
  
  If tbl.ShowAutoFilter Then tbl.Range.AutoFilter
  For i = 1 To tbl.ListRows.Count
    m = tbl.DataBodyRange(i, tbl.ListColumns("LocationCode").Index).Value
    If WorksheetFunction.CountIfs(tbl.ListColumns("LocationCode").DataBodyRange, m, tbl.ListColumns("ServiceType").DataBodyRange, "H") = 0 Then
      dic(m) = Empty
    End If
  Next
  
  If dic.Count > 0 Then
    tbl.Range.AutoFilter tbl.ListColumns("LocationCode").Index, dic.keys, xlFilterValues
    tbl.AutoFilter.Range.Offset(1).EntireRow.Delete
    If tbl.ShowAutoFilter Then tbl.Range.AutoFilter
  End If
End Sub

 

[nirvehex]

Try the following macro...

Option Explicit

Sub Delete_Non_H_Locations()

    'create a dictionary object to hold unique location codes
    Dim locationsDictionary As Object
    Set locationsDictionary = CreateObject("Scripting.Dictionary")
   
    'set dictionary to case-insensitive comparison mode
    locationsDictionary.comparemode = 1 'vbTextCompare
   
    'set the source table (change the sheet name accordingly)
    Dim sourceTable As ListObject
    Set sourceTable = Worksheets("Sheet1").ListObjects("Table2")
   
    'if source table is filtered, clear any and all filters
    With sourceTable
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
   
    'loop through each cell in LocationCode column and fill dictionary with unique location codes
    Dim currentCell As Range
    For Each currentCell In sourceTable.ListColumns("LocationCode").DataBodyRange
        locationsDictionary(currentCell.Value) = ""
    Next currentCell
   
    'filter source table for each unique location, and delete all rows if it doesn't have a service type "H"
    With sourceTable
        Dim currentKey As Variant
        For Each currentKey In locationsDictionary
            .Range.AutoFilter field:=.ListColumns("LocationCode").Index, Criteria1:=currentKey
            If Application.CountIf(.ListColumns("ServiceType").DataBodyRange.SpecialCells(xlCellTypeVisible), "H") = 0 Then
                With .Range
                    .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                End With
            End If
        Next currentKey
        .AutoFilter.ShowAllData
    End With
   
End Sub

Hope this helps!

Domenic,

Thanks for the detailed explanations in each section! That was so helpful!

 

[nirvehex]

Here is another macro for you to consider

Sub test()
  Dim dic As Object, i As Long, m As Variant, tbl As ListObject
 
  Set dic = CreateObject("scripting.dictionary")
  Set tbl = ActiveSheet.ListObjects("Table2")
 
  If tbl.ShowAutoFilter Then tbl.Range.AutoFilter
  For i = 1 To tbl.ListRows.Count
    m = tbl.DataBodyRange(i, tbl.ListColumns("LocationCode").Index).Value
    If WorksheetFunction.CountIfs(tbl.ListColumns("LocationCode").DataBodyRange, m, tbl.ListColumns("ServiceType").DataBodyRange, "H") = 0 Then
      dic(m) = Empty
    End If
  Next
 
  If dic.Count > 0 Then
    tbl.Range.AutoFilter tbl.ListColumns("LocationCode").Index, dic.keys, xlFilterValues
    tbl.AutoFilter.Range.Offset(1).EntireRow.Delete
    If tbl.ShowAutoFilter Then tbl.Range.AutoFilter
  End If
End Sub

Thanks for the alternative solution!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.