No Pair

[blackie42]

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

18768

Really appreciate any help with this

Thanks
Jon

[rlv]

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


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

[rlv]

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 :) )



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

[mdmackillop]

My try; results match RLV's second 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

[rlv]

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.

[mdmackillop]

There is some info and code examples here (http://stackoverflow.com/documentation/vba/3667/scripting-dictionary-object#t=20170325232655897243)
Regards
MD

[blackie42]

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

[blackie42]

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

[blackie42]

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

[mdmackillop]

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

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

[blackie42]

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

[snb]

I think this is sufficient:


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

[mdmackillop]

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

[blackie42]

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