none
VBA that fints the same number in two columns RRS feed

  • Question

  • I want to write a code that finds the same numbers in two columns and eliminate them, and the other to write to a new sheet. Can you help me?
    I want to write a code that finds the same numbers in two columns and eliminate them, and the others to write to a new sheet. Can you give me a hand?
    I want to write a code that finds the same numbers in two columns and eliminate them, and the others to write to a new sheet. Can you give me a hand?
    Wednesday, May 10, 2017 7:40 AM

All replies

  • Copy all data into a new sheet.

    Loop through each cell in one column, search the number with Range.Find in the other column.
    Combine the cells in each column in a Range object using Union if found. The code below might be helpful for that.

    After that you have 2 Range objects that refers to the double numbers in each column. Delete the Range object using Shift:=xlShiftUp

    Andreas.

    Function FindAll(ByVal Where As Range, ByVal What, _
        Optional ByVal After As Variant, _
        Optional ByVal LookIn As XlFindLookIn = xlValues, _
        Optional ByVal LookAt As XlLookAt = xlWhole, _
        Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _
        Optional ByVal SearchDirection As XlSearchDirection = xlNext, _
        Optional ByVal MatchCase As Boolean = False, _
        Optional ByVal SearchFormat As Boolean = False) As Range
      'Find all occurrences of What in Where (Windows version)
      Dim FirstAddress As String
      Dim c As Range
      'From FastUnion:
      Dim Stack As New Collection
      Dim Temp() As Range, Item
      Dim i As Long, j As Long
    
      If Where Is Nothing Then Exit Function
      If SearchDirection = xlNext And IsMissing(After) Then
        'Set After to the last cell in Where to return the first cell in Where in front if _
          it match What
        Set c = Where.Areas(Where.Areas.Count)
        'BUG in XL2010: Cells.Count produces a RTE 6 if C is the whole sheet
        'Set After = C.Cells(C.Cells.Count)
        Set After = c.Cells(c.Rows.Count * CDec(c.Columns.Count))
      End If
    
      Set c = Where.Find(What, After, LookIn, LookAt, SearchOrder, _
        SearchDirection, MatchCase, SearchFormat:=SearchFormat)
      If c Is Nothing Then Exit Function
    
      FirstAddress = c.Address
      Do
        Stack.Add c
        If SearchFormat Then
          'If you call this function from an UDF and _
            you find only the first cell use this instead
          Set c = Where.Find(What, c, LookIn, LookAt, SearchOrder, _
            SearchDirection, MatchCase, SearchFormat:=SearchFormat)
        Else
          If SearchDirection = xlNext Then
            Set c = Where.FindNext(c)
          Else
            Set c = Where.FindPrevious(c)
          End If
        End If
        'Can happen if we have merged cells
        If c Is Nothing Then Exit Do
      Loop Until FirstAddress = c.Address
    
      'FastUnion algorithm © Andreas Killer, 2011:
      'Get all cells as fragments
      ReDim Temp(0 To Stack.Count - 1)
      i = 0
      For Each Item In Stack
        Set Temp(i) = Item
        i = i + 1
      Next
      'Combine each fragment with the next one
      j = 1
      Do
        For i = 0 To UBound(Temp) - j Step j * 2
          Set Temp(i) = Union(Temp(i), Temp(i + j))
        Next
        j = j * 2
      Loop Until j > UBound(Temp)
      'At this point we have all cells in the first fragment
      Set FindAll = Temp(0)
    End Function

    Wednesday, May 10, 2017 2:35 PM