No Pair

Hi

Can anyone help with a macro to delete rows where there is NOT at least a pair of entries in column B sharing a reference in column A

So column B would have at least one 'Switch Out' and one 'Switch In' with the same reference in column A

Spreadsheet could have 2-3000 rows in total

Have attached a test sheet and highlighted in red rows that fit the criteria

Attachment 18768

Really appreciate any help with this

Thanks
Jon

If I understand the problem correctly, this might get you started

Code:

---

Sub NoPairDelete()
    Dim WS As Worksheet
    Dim ColCnt As Long, RowCnt As Long
    Dim KeyCol As Long, DelCol As Long
    Dim CellRange As Range
    Dim DataRange As Range
    Dim DelRange As Range
    Dim KeyRange As Range
    Dim FormulaStr As String


    Set WS = ThisWorkbook.Worksheets("Sheet1")


    With WS.UsedRange
        ColCnt = .Columns.Count
        RowCnt = .Rows.Count
        KeyCol = ColCnt + 1
        DelCol = ColCnt + 2
        Set DataRange = .Offset(1, 0).Resize(RowCnt - 1, 1)
        Set KeyRange = DataRange.Offset(0, KeyCol - 1)
        Set DelRange = DataRange.Offset(0, DelCol - 1)
    End With


    For Each CellRange In DataRange
        With CellRange
            FormulaStr = "=" & .Address & " & " & .Offset(0, 1).Address
            .Offset(0, KeyCol - 1).Formula = FormulaStr
        End With
    Next CellRange


    For Each CellRange In DataRange
        With CellRange
            FormulaStr = "=COUNTIF(" & KeyRange.Address & "," & .Address & " & " & """" & "Switch In" & """" & ")"
            FormulaStr = FormulaStr & " + COUNTIF(" & KeyRange.Address & "," & .Address & " & " & """" & "Switch Out" & """" & ")"
            .Offset(0, DelCol - 1).Formula = FormulaStr
        End With
    Next CellRange


    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If


    Set DataRange = WS.UsedRange
    DataRange.AutoFilter Field:=DelCol, Criteria1:="1"
    ColCnt = WS.UsedRange.Columns.Count
    If DataRange.SpecialCells(xlCellTypeVisible).Cells.Count > ColCnt Then
        Set DelRange = DataRange.Offset(1, 0).Resize(RowCnt - 1, WS.UsedRange.Columns.Count).SpecialCells(xlCellTypeVisible)
        DelRange.EntireRow.Delete
    End If


    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If


    WS.Columns(DelCol).Delete
    WS.Columns(KeyCol).Delete
    Set DataRange = WS.UsedRange
    Set DataRange = Nothing
    Set DelRange = Nothing
    Set KeyRange = Nothing
    Set CellRange = Nothing
End Sub

---

On further reflection, I think my earlier equation for the autofilter cells will miss multiple instances of the same non-matching Account-Transaction so I revised it slightly (and it's certainly possible I've misunderstood what you are after :) )

Code:

---

Sub NoPairDelete()
    Dim WS As Worksheet
    Dim ColCnt As Long, RowCnt As Long
    Dim KeyCol As Long, DelCol As Long
    Dim CellRange As Range
    Dim DataRange As Range
    Dim DelRange As Range
    Dim KeyRange As Range
    Dim FormulaStr As String
    Dim FormulaStr2 As String


    Set WS = ThisWorkbook.Worksheets("Sheet1")


    With WS.UsedRange
        ColCnt = .Columns.Count
        RowCnt = .Rows.Count
        KeyCol = ColCnt + 1
        DelCol = ColCnt + 2
        Set DataRange = .Offset(1, 0).Resize(RowCnt - 1, 1)
        Set KeyRange = DataRange.Offset(0, KeyCol - 1)
        Set DelRange = DataRange.Offset(0, DelCol - 1)
    End With


    For Each CellRange In DataRange
        With CellRange
            FormulaStr = "=" & .Address & " & " & .Offset(0, 1).Address
            .Offset(0, KeyCol - 1).Formula = FormulaStr
        End With
    Next CellRange
   
    For Each CellRange In DataRange
        With CellRange
            FormulaStr = "COUNTIF(" & KeyRange.Address & "," & .Address & " & " & """" & "Switch In" & """" & ")"
            FormulaStr = "=IF(" & FormulaStr & "=0," & """" & "!" & """" & "," & """" & """" & ")"
            FormulaStr2 = "COUNTIF(" & KeyRange.Address & "," & .Address & " & " & """" & "Switch Out" & """" & ")"
            FormulaStr2 = " & IF(" & FormulaStr2 & "=0," & """" & "!" & """" & "," & """" & """" & ")"
            FormulaStr = FormulaStr & FormulaStr2
            .Offset(0, DelCol - 1).Formula = FormulaStr
        End With
    Next CellRange


    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If


    Set DataRange = WS.UsedRange
    DataRange.AutoFilter Field:=DelCol, Criteria1:="!"
    ColCnt = WS.UsedRange.Columns.Count
    If DataRange.SpecialCells(xlCellTypeVisible).Cells.Count > ColCnt Then
        Set DelRange = DataRange.Offset(1, 0).Resize(RowCnt - 1, WS.UsedRange.Columns.Count).SpecialCells(xlCellTypeVisible)
        DelRange.EntireRow.Delete
    End If


    If WS.AutoFilterMode Then
        WS.AutoFilterMode = False
    End If


    WS.Columns(DelCol).Delete
    WS.Columns(KeyCol).Delete
    Set DataRange = WS.UsedRange
    Set DataRange = Nothing
    Set DelRange = Nothing
    Set KeyRange = Nothing
    Set CellRange = Nothing
End Sub

---

My try; results match RLV's second code

Code:

---

Option Explicit
Sub Test()
Dim Dic As Object, d
Dim r As Range, c As Range, cel As Range, rng As Range
Dim x As Boolean, y As Boolean
Dim FirstAddress As String


Set Dic = CreateObject("Scripting.Dictionary")
Set r = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
On Error Resume Next
For Each cel In r
Dic.Add CStr(cel), CStr(cel)
Next cel
On Error GoTo 0


For Each d In Dic.items
x = False: y = False
Set rng = Nothing
Set c = r.Find(d)
        FirstAddress = c.Address
        Do
            If c.Offset(, 1) = "Switch Out" Then x = True
            If c.Offset(, 1) = "Switch In" Then y = True
            If x And y Then Exit Do
            If rng Is Nothing Then
                Set rng = c
            Else
                Set rng = Union(rng, c)
            End If
            Set c = r.FindNext(c)
        Loop While c.Address <> FirstAddress
    If (x And y) Then
    'do nothing
    Else
    rng.Interior.ColorIndex = 45  'Delete after test
    'rng.EntireRow.Delete  'Use this instead
    End If
Next
End Sub

---

Code:

---

Set Dic = CreateObject("Scripting.Dictionary")

---

Very nice. Dictionaries are really good for filtering non-unique values (among other things). Many years ago I created my own string dictionary class and I was totally unaware that there was now a standard VB/VBA dictionary object. Can you point me in the general direction of any documentation about the object?

Thx.

There is some info and code examples here
Regards
MD

Thanks Guys,

Both versions work fine on the test sheet.

Will try on the real thing tomorrow and then close the thread

much appreciated

regards
Jon

All Ok - thanks for the help Guys

Have some more manipulation to do but will close this thread.

May need to ask for more help if the logic is too complicated

regards
Jon

Attachment 19760

Hi Guys,

I've added the test file with the added complication - the additional condition is to also check the ID - so

so a true pair would be

column A reference has at least a 'Switch In' and a 'Switch Out' but also shares the same ID in column G

Highlighted an example where there is a at least a matching pair but they don't share the same ID

Again I'd like to remove any of these rows

Would really appreciate any help with this.


Jon

This shows results in Column H. Just add your delete routine

Code:

---

Option Explicit
Sub Test()
    Dim Dic As Object, d
    Dim r As Range, c As Range, cel As Range, rng As Range
    Dim x As Boolean, y As Boolean
    Dim FirstAddress As String
   
   
    Set Dic = CreateObject("Scripting.Dictionary")
    Set r = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
    For Each cel In r
    cel.Offset(, 7) = cel.Offset(, 5) & "/" & cel
    Next
    Set r = r.Offset(, 7)
   
    On Error Resume Next
    For Each cel In r
        Dic.Add CStr(cel), CStr(cel)
    Next cel
    On Error GoTo 0
     
    For Each d In Dic.items
        x = False: y = False
        Set rng = Nothing
        Set c = r.Find(d)
        FirstAddress = c.Address
        Do
            If c.Offset(, -6) = "Switch Out" Then x = True
            If c.Offset(, -6) = "Switch In" Then y = True
            If x And y Then Exit Do
            If rng Is Nothing Then
                Set rng = c
            Else
                Set rng = Union(rng, c)
            End If
            Set c = r.FindNext(c)
        Loop While c.Address <> FirstAddress
        If (x And y) Then
            'do nothing
        Else
            rng.Interior.ColorIndex = 45 'Delete after test
        End If
    Next
End Sub

---

Attachment 19762

Hi Mdmack,

This works really good - thank you so much.

I have one final task on this and possibly the most complicated.

What I need to do is first create a blank row between the switch IDs (col F), then look at all the SW BUY on that ID and compare to
all the SW SELL same ID to see if any of the SW BUY has a date that predates any of the SW SELLs. Does that make sense?

I've attached a test sheet to try and show what the expected results would be. Amber BUY dates predate SELL date (same date is OK)

I'd be so grateful if you could figure this out as it's way beyond my capability.

Thanks again

Jon

I think this is sufficient:

Code:

---

Sub M_snb()
    sn = Sheet1.Cells(1).CurrentRegion
   
    With CreateObject("scripting.dictionary")
        For j = 2 To UBound(sn)
          .Item(sn(j, 1)) = .Item(sn(j, 1)) + 1
        Next
        For Each it In .keys
          If .Item(it) = 1 Then Columns(1).Replace it, "", 1
        Next
    End With
   
    Columns(1).SpecialCells(4).EntireRow.Delete
End Sub

---

See also: http://www.snb-vba.eu/VBA_Dictionary_en.html

Code:

---

Sub Test()
    Dim i&, j&, k&, lr&, MaxSell&
    Dim r As Range
   
    Cells(1, 7).EntireColumn.Insert
    j = 1
    lr = Cells(Rows.Count, 6).End(xlUp).Row
    Cells(lr, 7) = j
    For i = lr To 2 Step -1
        If Cells(i, 6) <> Cells(i - 1, 6) Then
            j = j + 1
            Cells(i, 6).EntireRow.Insert
            Cells(i - 1, 7) = j
        End If
    Next i


    For i = 1 To j - 1
        Set r = Columns(7).Find(i, lookat:=xlWhole).CurrentRegion.Resize(, 6)
        MaxSell = 0
        For k = 1 To r.Rows.Count
            If r(k, 2) = "SW SELL" And r(k, 4) > MaxSell Then MaxSell = r(k, 4)
        Next k
        For k = 1 To r.Rows.Count
            If r(k, 2) = "SW BUY" And IsDate(r(k, 4)) And r(k, 4) < MaxSell Then r(k, 4).Interior.ColorIndex = 7
        Next k
    Next i


    Columns(7).Delete
    Rows(2).Delete


End Sub

---

Thanks snb - MdMacks code works and is already in the full code.

MdMack - the code to identify timing differences also works great - I've tested it on the full worksheet but need to a lot more testing before implementing.

Thanks very much for all your help - this has saved my team a lot of manual work.

regards
Jon