Consulting

Results 1 to 14 of 14

Thread: No Pair

  1. #1

    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

    NoPair.xlsx

    Really appreciate any help with this

    Thanks
    Jon
    Last edited by blackie42; 03-25-2017 at 12:31 PM. Reason: spelling

  2. #2
    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

  3. #3
    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

  4. #4
    Administrator
    VP-Knowledge Base
    VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  5. #5
    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.

  6. #6
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    There is some info and code examples here
    Regards
    MD
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  7. #7
    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

  8. #8
    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

  9. #9
    NoPair2.xlsx

    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

  10. #10
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  11. #11
    SWTest.xlsx

    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

  12. #12
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,774
    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

  13. #13
    Administrator
    VP-Knowledge Base VBAX Grand Master mdmackillop's Avatar
    Joined
    May 2004
    Location
    Scotland
    Posts
    14,489
    Location
    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
    MVP (Excel 2008-2010)

    Post a workbook with sample data and layout if you want a quicker solution.


    To help indent your macros try Smart Indent

    Please remember to mark threads 'Solved'

  14. #14
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •