Страницы: 1
RSS
Удаление одинаковых пар в двух столбцах
 
Добрый день, уважаемые форумчане! Уже второй день никак не могу решить одну, казалось бы простую задачу. Кажется, что решение где-то на поверхности должно быть, но смотрю в упор - и не вижу! Суть такая: есть два столбца,в которых хранятся сочетания товаров,и нужно удалить дубликаты, но не совсем простым способом. Например, есть сочетание соль - молоко в количестве 4 сочетания и молоко - соль в количестве 4 сочетания. Для автоматического удаления дубликатов - это разные строки, и excel их пропускает, а для моей задачи - это дубликаты, который далее мне существенно замедляют анализ. Наблюдений более 120 тыс., очень нужно автоматизировать поиск и удаление таких дубликатов.
Буду благодарна за любые мысли!  
 
попробуйте вдохновиться новой статьей в приемах
Нечёткий текстовый поиск в Power Query
Если у Вас еще нет этой возможности, то почитайте прежнюю статью Нечеткий текстовый поиск с Fuzzy Lookup в Excel
=============================UPDATE=========================­===========
Если же Вам заранее известны варианты названий позиций, то можно в отдельной таблице пронумеровать их простыми числами и во вспомогательном столбце записывать произведения этих простых. А затем удалять дубликаты уже по этому столбцу.
=============================UPDATE-2===================================
Если не хочется связываться с простыми числами, то во вспомогательный столбец можно записывать конкатенацию (сцепку) двух названий позиций, первое из которых должно начитаться с младшего/старшего символа(-ов) по сравнению с началом второго названия.
Изменено: IKor - 25.03.2020 14:41:08
 
aleksa_yara, а получается нужно оставить только один из дубликатов? или все удалить?!
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
есть сочетание соль - молоко в количестве 4 сочетания и молоко - соль в количестве 4 сочетания
Что оставить сочетание соль - молоко в количестве 8 ?
 
 нужно не только соль - молоко еще и количество сопоставлять? только в этом случае они являются дубликатами?
Изменено: Mershik - 25.03.2020 15:09:18
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
IKor написал:
Если же Вам заранее известны варианты названий позиций, то можно в отдельной таблице пронумеровать их  простыми числами  и во вспомогательном столбце записывать произведения этих простых. А затем удалять дубликаты уже по этому столбцу.
Большое спасибо за варианты! С простыми числами получилось! А во вспомогательном столбце числа искать из отдельной таблицы только с помощью ВПР? Или есть еще какие-то варианты? А то при выполнении ВПР на больших данных очень уж у меня виснет excel.
C первым вариантом еще буду пробовать, третий не поняла, к сожалению: сцепку сделать думала, а вот условие про младший/старший символ не совсем понятно. Вы имеете в виде порядок букв в алфавите?  
 
вариант (без количества)
Код
=ЕСЛИ(ЕЧИСЛО(ПОИСКПОЗ(A2&B2;$B$2:$B$8&$A$2:$A$8;0));"дубль";"нет")


или так
Код
=СУММПРОИЗВ(--(A6&B6=($B$2:B6&$A$2:A6)))

формула массива
Изменено: Stics - 25.03.2020 20:09:08
 
Mershik, да, нужно оставить только один дубликат. По поводу количества: я на предыдущем этапе анализа уже свела к едином количеству каждое сочетание. До этого у меня было соль - молоко 4 шт и молоко - соль 5 шт. Я получила соль - молоко - 9 шт и молоко - соль - 9 шт. Думала, что это упростит мне удаление дублей. То есть, один вариант нужно удалить без пересчета

Kuzmich, если есть вариант сделать так - было бы даже лучше, так как я до этого как раз и занималась тем, что суммировала с помощью функции "СУММЕСЛИМН" , чтобы получить у каждой пары соль - молоко и молоко - соль уже итоговое количество сочетаний, изначально количества были разные
Цитата
Kuzmich написал:
Что оставить сочетание соль - молоко в количестве 8 ?
 
Всем большое СПАСИБО! Stics, спасибо за отличный вариант! Добавила еще количество, вдруг где-то в предыдущем анализе у меня были ошибки - заодно проверю! Наконец-то сдвинулась с вашей помощью с мертвой точки! Буду совершенствоваться в возможностях excel  :D , такие вещи вы мне сегодня показали интересные!    
 
Цитата
aleksa_yara написал:
ВПР? Или есть еще какие-то варианты?
Варианты есть, но ВПР - один из лидеров по скорости обработки данных

Цитата
aleksa_yara написал:
Вы имеете в виде порядок букв в алфавите?
Да, я имел в виду провести сортировку названий в одной строке по возрастанию/убыванию
 
Stics, получается, если удалим все строки, где появились дубли, то уникальных значений не останется, то есть соль - молоко дубль и молоко - соль дубль будут удалены, не очень хорошо...  
 
IKor, остановилась на вашем решении с простыми числами, так получается оставить уникальные и удалить второе совпадение.
 
aleksa_yara, написала
Цитата
если есть вариант сделать так - было бы даже лучше
Проверьте такой вариант
Код
Sub DelDubl()
Dim i As Long
Dim iLastRow As Long
Dim Para As String
Dim ParaRev As String
Dim FoundPoz As Range
Dim iRow As Long
Dim FAdr As String
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow - 1         'проверяем есть ли дубликаты Para и ParaRev
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(Para, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then 'нашли Para после Cells(i, 1)
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще Para в столбце А
       Do
        If FoundPoz.Offset(, 1) = ParaRev Then
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)   'есди дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).FindNext(FoundPoz)
       Loop While FoundPoz.Address <> FAdr
      End If
    End If
  Next
  For i = 2 To iLastRow - 1     'проверяем есть ли дубликаты ParaRev и Para
    Para = Cells(i, 1)
    ParaRev = Cells(i, 2)
    Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
    If Not FoundPoz Is Nothing Then
      FAdr = Cells(i, 1).Address
      If Not FoundPoz.Address = FAdr Then    'есть ли еще ParaRev в столбце А
       Do
        If FoundPoz.Offset(, 1) = Para Then
         iRow = FoundPoz.Row
         Cells(i, 3) = Cells(i, 3) + FoundPoz.Offset(, 2)  'есди обратн. дубликат, то суммируем кол-во
         Range("A" & FoundPoz.Row & ":C" & FoundPoz.Row).Delete
         iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        End If
          If iRow = iLastRow + 1 Then Exit Do
        Set FoundPoz = Range("A" & i & ":A" & iLastRow).Find(ParaRev, , xlValues, xlWhole)
       Loop While Not FoundPoz Is Nothing
      End If
    End If
  Next
End Sub
 
aleksa_yara, посмотрите, исправил в #7
 
Пробуйте:
 
aleksa_yara,
Еще попробуйте вариант
Код
Sub UniqPara()
Dim i As Long
Dim iLastRow As Long
Dim dic As Object
 iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Set dic = CreateObject("scripting.dictionary"): dic.comparemode = 1
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + Cells(i, "C") 'сумма в dic.items
  Next
  For i = 2 To iLastRow
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) = _
    dic.Item(CStr(Cells(i, "A").Value & "_" & Cells(i, "B").Value)) + _
    dic.Item(CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value))
    dic.Remove CStr(Cells(i, "B").Value & "_" & Cells(i, "A").Value)
  Next
  [D2].Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.items))
End Sub

Удачи!
 
Еще вариант
Код
Sub main()
    Dim arr(), dic As Object, txt$
    Dim lrow&, i&, ikey
    
    Set dic = CreateObject("scripting.dictionary")
    lrow = Range("a" & Rows.Count).End(xlUp).Row
    arr = Range("a2:c" & lrow).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) > arr(i, 2) Then
            txt = arr(i, 1) & "|" & arr(i, 2)
        Else: txt = arr(i, 2) & "|" & arr(i, 1)
        End If
        dic.Item(txt) = arr(i, 3)
    Next i
    Erase arr: i = 0
    ReDim arr(dic.Count, 3)
    For Each ikey In dic.keys
        arr(i, 0) = Split(ikey, "|", 2)(0)
        arr(i, 1) = Split(ikey, "|", 2)(1)
        arr(i, 2) = dic.Item(ikey)
        i = i + 1
    Next ikey
    [a1].Resize(, 3).Copy [e1]
    [e2].Resize(dic.Count, 3).Value = arr
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Stics, Андрей_26, Kuzmich, Nordheim, Господа, спасибо вам большое! Все работает! Правда, когда запускаю макрос на 100-200 тыс. наблюдений, то все зависает на час-два с непредсказуемым исходом, но, скорее всего, это уже проблемы моей оперативки на 4 ГБ  :oops: . Буду еще на другом ПК тестировать. Спасибо еще раз за отзывчивость и позвольте восхититься вашими интеллектуальными способностями!  
 
aleksa_yara, Вы уверены что код из #17 сообщения отрабатывает 1-2 часа, сделал 180 тыс. строк, на своем старом ПК 4 гб. оперативки Core2Quad Q6600
Отработал за 10-15 сек.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
Цитата
If arr(i, 1) > arr(i, 2) Then
А что в массивах можно СЫР сравнивать с ПЕЧЕНЬЕМ ?
Как это происходит?
 
Kuzmich,
А почему бы и нет?
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim,
И количество по вашему варианту не совпадает, например
Сыр Печенье 2     а д.б. 8
 
Kuzmich,
А где написано что нужно суммировать?, как нужно я в файле не увидел, увидел только помеченные пересечения
"Все гениальное просто, а все простое гениально!!!"
 
Ну а если нужна сумма то пожалуйста
Код
Sub main()
    Dim arr(), dic As Object, txt$
    Dim lrow&, i&, ikey
     
    Set dic = CreateObject("scripting.dictionary")
    lrow = Range("a" & Rows.Count).End(xlUp).Row
    arr = Range("a2:c" & lrow).Value
    For i = 1 To UBound(arr)
        If arr(i, 1) > arr(i, 2) Then
            txt = arr(i, 1) & "|" & arr(i, 2)
        Else: txt = arr(i, 2) & "|" & arr(i, 1)
        End If
        dic.Item(txt) = dic.Item(txt) + arr(i, 3)
    Next i
    Erase arr: i = 0
    ReDim arr(dic.Count, 3)
    For Each ikey In dic.keys
        arr(i, 0) = Split(ikey, "|", 2)(0)
        arr(i, 1) = Split(ikey, "|", 2)(1)
        arr(i, 2) = dic.Item(ikey)
        i = i + 1
    Next ikey
    [a1].Resize(, 3).Copy [e1]
    [e2].Resize(dic.Count, 3).Value = arr
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Вот теперь нормально. Всего доброго!
Страницы: 1
Наверх