Excel VBA - delete range of cells based on criteria

1
votes

I want to delete a "row-range" of cells and shift them up, if one cell (column K8:Kxxxx) isn't "6-Other miscellaneous Cluster". 

With wb2.Sheets("CALC")
    .Range("L8:L" & LastRow3).Formula = "=IF(G8="""","""",CONCATENATE(G8,""/"",VALUE(TEXT(I8,""00#""))))" 'REF'
End With

deleteIds = Array("OTIF", "2-Stock Availability on Non Stock item", "1-Not in full or rejected", "3-Stock Availability on Stock item", "4-Credit Release after MAD", "5-Actual PGI after planned PGI") ' Put your employee ids in here
For Each employeeId In Range(ActiveSheet.Range("K8"), ActiveSheet.Range("K8").End(xlDown))
   If Not (IsError(Application.Match(employeeId.Value, deleteIds, 0))) Then
       ActiveSheet.Range("G" & employeeId.Row).Value = ""
       ActiveSheet.Range("H" & employeeId.Row).Value = ""
       ActiveSheet.Range("I" & employeeId.Row).Value = ""
       ActiveSheet.Range("J" & employeeId.Row).Value = ""
       ActiveSheet.Range("K" & employeeId.Row).Value = ""
       ActiveSheet.Range("L" & employeeId.Row).Value = ""
   End If
Next

lastrow4 = Range("D:D").End(xlDown).Row
For i = lastrow4 To 1 Step -1
    If IsEmpty(Cells(i, "D").Value2) Then
        Cells(i, "G8:L50000").Delete Shift:=xlShiftUp
    End If
Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "DONE!"

This is just the part of the macro, where i tried to delete the cells that don't match the criteria. At the moment the macro looks for every possible value except "06-Other..." and clears the content of the cells in range G8:Lxxx. But I can't get it to delete and shift up the blank cells. Hopefully someone can solve my Problem.

2
vbaexcel

2 Answers

1
votes

You can use a DelRng object of type Range, and every time it matches (or doesn't match) your criteria, you add this range toDelRngusing theUnion` function.

Note: try to avoid using ActiveSheet, instead use fully qualifed Worksheets object (see code below):

Dim DelRng As Range

With ThisWorkbook.Sheets("Sheet1") ' <-- modify "Sheet1" to your sheet's name
    deleteIds = Array("OTIF", "2-Stock Availability on Non Stock item", "1-Not in full or rejected", "3-Stock Availability on Stock item", "4-Credit Release after MAD", "5-Actual PGI after planned PGI") ' Put your employee ids in here
    For Each employeeId In .Range(.Range("K8"), .Range("K8").End(xlDown))
        If Not (IsError(Application.Match(employeeId.Value, deleteIds, 0))) Then
            If Not DelRng Is Nothing Then
                Set DelRng = Application.Union(DelRng, .Range(.Cells(employeeId.Row, "G"), .Cells(employeeId.Row, "L")))
            Else
                Set DelRng = .Range(.Cells(employeeId.Row, "G"), .Cells(employeeId.Row, "L"))
            End If
        End If
    Next
End With

' delete entire range at one-shot
If Not DelRng Is Nothing Then DelRng.Delete
0
votes

This will delete and shift up the cells in the 6 columns after the matched criteria. 

    With wb2.Sheets("CALC")
             .Range("L8:L" & LastRow3).Formula = "=IF(G8="""","""",CONCATENATE(G8,""/"",VALUE(TEXT(I8,""00#""))))" 'REF'
        End With

Dim lStartRow As Long
Dim lEndRow As Long
Dim lSearchColumn As Integer
Dim lRow As Long

lStartRow = 8
lSearchColumn = 11
lEndRow = ActiveSheet.Range("K8").End(xlDown)

For lRow = lEndRow To lStartRow Step -1

    If Not (IsError(Application.Match(Cells(lRow, lSearchColumn), deleteIds, 0))) Then

        Cells(lRow, lSearchColumn + 1).Delete shift: xlShiftUp
        Cells(lRow, lSearchColumn + 2).Delete shift: xlShiftUp
        Cells(lRow, lSearchColumn + 3).Delete shift: xlShiftUp
        Cells(lRow, lSearchColumn + 4).Delete shift: xlShiftUp
        Cells(lRow, lSearchColumn + 5).Delete shift: xlShiftUp
        Cells(lRow, lSearchColumn + 6).Delete shift: xlShiftUp

    End If

Next



Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "DONE!"