Complex logic formula to delete values

**randell.graybill** · 11-14-2009, 02:14 AM

The concept is fairly simple but the logic is not. Basically I have some values that repeat themselves and need to be deleted when they repeat. Please see the attached file for further details (you need the additional details to answer this question).

upon further consideration I thought that it would be best to probably do everything in two passes or maybe not see below macro to get an idea of how the end process should function

Range("G42").FormulaR1C1 = _
        "=IF(AND(RC[-3]=R[1]C[-3],R[2]C[-3]=R[3]C[-3]),IF(AND(RC[-6]=R[2]C[-6],R[1]C[-6]=R[3]C[-6]),TRUE,FALSE))"
  If Range("G42").Value = True Then
Rows("43:44").Delete Shift:=xlUp
Range("G42").Value = NullString
End If

**DonkeyOte** · 11-14-2009, 04:15 AM

Does this work for you ?

Test on a backup sheet first of course!

Public Sub Example()
Dim xlCalc As XlCalculation, lngCell As Long, lngCount As Long
On Error GoTo ExitPoint
With Application
    xlCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
With Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 1)
    With .Offset(, -1)
        .FormulaR1C1 = "=RC1&"":""&RC3&"":""&RC4"
        .Value = .Value
    End With
    .FormulaR1C1 = "=SUM(COUNTIF(R1C[-1]:R[-1]C[-1],RC1&"":""&RC3&""*""),COUNTIF(R1C[-1]:R[-1]C[-1],""*""&RC3&"":""&RC4))"
    For lngCell = 1 To .Cells.Count Step 1
        With .Cells(1 + lngCount)
            .Calculate
            If .Value Then .EntireRow.Delete Else lngCount = lngCount + 1
        End With
    Next lngCell
    .Offset(, -1).Resize(, 2).Clear
End With
ExitPoint:
With Application
    .ScreenUpdating = True
    .Calculation = xlCalc
    .EnableEvents = True
End With
End Sub

I think in reality given the almost recursive nature of the calcs you need to iterate from top to bottom ... given latter rows may appear as though they are duplicates until such time as earlier rows are removed (eg row 23)
ie you can only really determine unique nature of a given row as and when it is reached and all preceding rows have been dealt with accordingly (eg rows 21 & 22)

I suspect the above can be improved but this is more a test to see if the logic matches requirements.

**randell.graybill** · 11-14-2009, 10:23 PM

I believe I understand what you are trying to do, and yes the logic is correct, at this point the macro doesn't do anything however...the it seems it should work is when the values in column IV equal 1 in row subsequent rows then both rows should be deleted. The logic is perfect the macro doesn't delete the data...and I don't know why the macro looks sound.

**randell.graybill** · 11-14-2009, 11:35 PM

Donkey using the code you gave me I got it to work not so pretty (my code not yours) but it does the job. Thanks for the help!

Sub Two_PlusPallets()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Call Manual_Calculation

    Range("N2:N3000").FormulaR1C1 = _
        "=IF(RC[-13]="""","""",IF(RC[-11]<10,""0""&RC[-11]&""0"",RC[-11]&""0"")&IF(RC[-10]<10,""0""&RC[-10],RC[-10])&RC[-9])"
    
    Calculate
    
    Range("N1").FormulaR1C1 = "Location"
    Columns("N:N").Copy
    Columns("C:C").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
     Columns("C:C").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Range("L:N,I:J,D:F").DELETE Shift:=xlToLeft
    
    Range("G2:G3000").FormulaR1C1 = "=IF(RC[-6]="""","""",IF(COUNTIF(C[-4],RC[-4])=1,TRUE,FALSE))"
    
    Calculate
    
Call deletetrue_ColumnI

  Range("G:G").ClearContents
  

Dim xlCalc As XlCalculation, lngCell As Long, lngCount As Long
On Error GoTo ExitPoint
With Application
    xlCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
With Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 1)
    With .Offset(, -1)
        .FormulaR1C1 = "=RC1&"":""&RC3&"":""&RC4"
        .Value = .Value
    End With
    .FormulaR1C1 = "=SUM(COUNTIF(R1C[-1]:R[-1]C[-1],RC1&"":""&RC3&""*""),COUNTIF(R1C[-1]:R[-1]C[-1],""*""&RC3&"":""&RC4))"
    For lngCell = 1 To .Cells.Count Step 1
        With .Cells(1 + lngCount)
            .Calculate
            If .Value Then .EntireRow.DELETE Else lngCount = lngCount + 1
        End With
    Next lngCell
    .Offset(, -1).Resize(, 2).Clear
End With
ExitPoint:
With Application
    .ScreenUpdating = True
    .Calculation = xlCalc
    .EnableEvents = True
End With

With Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 7)
    With .Offset(, -1)
         .FormulaR1C1 = "=IF(OR((AND(RC256=1,R[1]C256=1)),AND(R[-1]C256=1,RC256=1)),""DELETE"",""NO DELETE"")"
'         .Value = .Value
End With
    End With
    
Dim R As Integer

For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountIf(Range("IO" & R & ":IO" & R), "DELETE") Then
Rows(R).DELETE
End If
Next R

Range("IO:IV").ClearContents

    
  Range("A1").Select
  
Application.DisplayAlerts = True
Application.ScreenUpdating = True
  
End Sub
Sub DeleteDups()
     
    Dim x               As Long
    Dim LastRow         As Long
     
    LastRow = Range("A65536").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("D1:D" & x), Range("D" & x).Text) > 1 Then
            Range("D" & x).EntireRow.DELETE
        End If
    Next x
    End Sub
Sub TESTSTUFF2PLUSPALELTS()
If Range("d20").Value = Range("D21").Value Then
Rows(21).EntireRow.DELETE
    If Range("A21").Value = Range("A20").Value Then
    Rows(21).EntireRow.DELETE
End If
    End If
End Sub
Sub moretesting()
Dim xlCalc As XlCalculation
On Error GoTo ExitPoint
With Application
    xlCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With
With Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp).Offset(-1)).Offset(, Columns.Count - 2)
    .FormulaR1C1 = "=IF(AND(RC[-4]=R[1]C[-4],RC[-3]=R[1]C[-3]),TRUE,FALSE)" <> True
   ' On Error Resume Next
    .SpecialCells(xlCellTypeFormulas, xlErrors).EntireRow.DELETE
    'On Error GoTo ExitPoint
    .Clear
End With
ExitPoint:
With Application
    .Calculation = xlCalc
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

Public Sub testlogic()

Dim xlCalc As XlCalculation, lngCell As Long, lngCount As Long
On Error GoTo ExitPoint
With Application
    xlCalc = .Calculation
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
With Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 1)
    With .Offset(, -1)
        .FormulaR1C1 = "=RC1&"":""&RC3&"":""&RC4"
        .Value = .Value
    End With
    .FormulaR1C1 = "=SUM(COUNTIF(R1C[-1]:R[-1]C[-1],RC1&"":""&RC3&""*""),COUNTIF(R1C[-1]:R[-1]C[-1],""*""&RC3&"":""&RC4))"
    For lngCell = 1 To .Cells.Count Step 1
        With .Cells(1 + lngCount)
            .Calculate
            If .Value Then .EntireRow.DELETE Else lngCount = lngCount + 1
        End With
    Next lngCell
    .Offset(, -1).Resize(, 2).Clear
End With
ExitPoint:
With Application
    .ScreenUpdating = True
    .Calculation = xlCalc
    .EnableEvents = True
End With

With Range(Cells(2, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, Columns.Count - 7)
    With .Offset(, -1)
         .FormulaR1C1 = "=IF(OR((AND(RC256=1,R[1]C256=1)),AND(R[-1]C256=1,RC256=1)),""DELETE"",""NO DELETE"")"
'         .Value = .Value
End With
    End With
    
Dim R As Integer

For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If WorksheetFunction.CountIf(Range("IO" & R & ":IO" & R), "DELETE") Then
Rows(R).DELETE
End If
Next R

Range("IO:IV").ClearContents

End Sub

**randell.graybill** · 11-14-2009, 11:37 PM

upon further examination it appears that it didn't delete everything in one pass...

[edit]

while the above is true it is no fault of the logic...it is due to there being a 3rd pallet with the same number...and since this happened to only 4 it is not important to fix it. thanks again Donkey.