Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Как сравнить 2 столбца ячеек на одном листе
 
#1
09.04.2012 16:00:45
Я бухгалтер. Практически каждый месяц сталкиваюсь с одной и той же проблемой:приходится вручную сравнивать две кипы бумаг, чтобы найти различия.  
В общем, есть 2 столбца (пусть даже на одном листе). Надо сравнить эти два столбца и выявить, какие ячейки у них не совпали, ркзультат вывести в третий столбец. Как правило, получается,что в каждом столбце около 200 значений, а несовпадений получается штуки три. Еще было бы просто замечательно, если ячейки одинаковые просто взаимоуничтожались. Плохо то,что одинаковые данные в столбцах не стоят напротив друг друга( а то бы я сама справилась)))). Одно данное может быть в самом начале одного листа, а его дублер может стоять в соседнем столбце ближе к концу листа.  
Надеюсь,кто-нибудь мне поможет.Грядет нервный срыв)
 
 
 
#2
09.04.2012 16:08:41
Нервному срыву - бой! :)  
 
Посмотрите в приемах статью "извлечение уникальных..."  
В Вашем случае будем вместо уникальных искать в столбце В те, у которых нет совпадений в столбце С.  
 
Доп.столбец A:  
=ЕСЛИ(ЕНД(ПОИСКПОЗ(B2;$C$2:$C$300;0));МАКС($A$1:A1)+1)  
Дальше - по статье.
 
 
 
#3
09.04.2012 16:17:25
С примером от автора, наш ответ будет понятней.
 
 
 
#4
09.04.2012 16:45:39
Спасибо за ответ. Но я делаю что-то неверно,видимо. Вогнала в лист 2 столбца:В и С. Вогнала формулу в столбец А...и всё..везде вылезло "ложь". Где я могла "накосячить"?
 
 
 
#5
09.04.2012 16:55:45
Я только что разбил чашку. Ну и ладно, на счастье.  
 
Видите, что осталось от красоты?
 
 
 
#6
09.04.2012 18:15:37
"Еще было бы просто замечательно, если ячейки одинаковые просто взаимоуничтожались" - вот такое я делал. Как раз на алгоритме поиска уникальных на словаре.  
Только там уничтожались не одинаковые, а пары +-. Но думаю это несложно будет скорректировать.  
Но файл где-то на работе - завтра поищу, если тема не затеряется.
 
 
 
#7
09.04.2012 21:43:52
Было бы здорово)
 
 
 
#8
09.04.2012 23:41:49
Но пока мы не увидим Ваши два столбца и результат в третьем - думаю толку Вам от того моего файла не будет...  
Вы ведь сами под свои данные его не скорректируете.
 
 
 
#9
09.04.2012 23:50:45
Посмотрите здесь:   
http://www.planetaexcel.ru/forum.php?thread_id=36497
 
 
 
#10
10.04.2012 09:28:49
Вслепую.  
Корректируйте.  
 
Sub DoublesRemoveTwoColumns()  
   Dim a, i&, s  
   a = [a1].CurrentRegion.Value
 
   With CreateObject("Scripting.Dictionary")  
       ' .CompareMode = 1  
       For i = 1 To UBound(a, 1): .Item(a(i, 1)) = i: Next  
 
       For i = 1 To UBound(a, 1)  
           s = a(i, 2)  
           If .Exists(s) Then  
               a(.Item(s), 1) = Empty  
               a(i, 2) = Empty  
               .Remove (s)  
           End If  
       Next  
 
   End With  
 
   [c1].Resize(UBound(a, 1), 2) = a
 
End Sub  
 
Чтоб убрать дубли из убранных дублей - запускать дубль :) (т.е. повторно на результате, но предварительно в диапазоне убрать пустые ячейки, или нужно иначе определять рабочий диапазон.)
 
 
 
#11
10.04.2012 13:29:36
Чтобы Юльчику легче осваивался код,  
написал пример макроса Hugo с "Кнопочкой"  
Так как не знаю цветовое предпочтение Hugo, то кнопочку покрасил в розовый цвет!
 
 
 
#12
10.04.2012 13:40:25
:)  
Я примерно на таких данных и тестировал. Только без кнопки - а если бы была, то была бы серебристо-серого цвета, у меня такая заготовлена :)  
И вот если на примере в обоих столбцах поставить по две двойки, то в результате останется по одной.  
Теперь нужно уплотнить результат (или переделать определение исходного диапазона), закинуть его снова в два первых столбца и запустить код ещё раз - тогда и эти двойки пропадут.
 
 
 
#13
11.04.2012 21:30:02
Я всем очень благодарна за ответы, но...техника в руках обезъяны...(это я про себя:-))). Короче, решила дать вам этот файл. Может быть, вы с ним что-то сделаете, а я потом попытаюсь разобраться. как и что вы с ним сделали))))) Хотя...самооценка стыдливо плачет в углу)
 
 
 
#14
11.04.2012 22:06:56
Ну Юльчик... :)  
Там ведь выше уже и файл с кодом есть (от Yelisey post_325882.xls) - его скачиваете, копируете свои цифры в две первые колонки, жмёте розовую кнопку (Вам нравится розовая? :) )  
Получаете рядом накиданные номера без пар.  
Если там есть повторы - а они там есть - собираете эти два столбца в кучку (без  пробелов), копируете снова в два первых столбца, снова жмёте кнопку.  
Если и на реальных данных много пар повторяются - тогда есть смысл код усовершенствовать...  
 
Ну например вот так - просто гоняю код 10 раз и выгружаю результат назад. Если мало - можно ещё раз нажать кнопку - ещё 10 раз пофильтрует :)  
Пробелы убирать не нужно - суммы остаются на своих родных местах.  
Если в итоге место не важно - можно каждый столбец отдельно отсортировать - цифры соберутся поплотнее.  
Не совсем то, что Вы хотели - без шашечек, но приехали :)
 
 
 
#15
11.04.2012 22:13:07
Или возможно лучше такая редакция - тут словарь каждый раз создаётся заново (хотя результат не изменился):  
 
Sub DoublesRemoveTwoColumns()  
   Dim a, i&, s, x&  
 
   For x = 1 To 10  
       With CreateObject("Scripting.Dictionary")  
           ' .CompareMode = 1  
 
           a = Intersect(ActiveSheet.UsedRange, [a:b]).Value
 
           For i = 1 To UBound(a, 1): .Item(a(i, 1)) = i: Next  
 
           For i = 1 To UBound(a, 1)  
               s = a(i, 2)  
               If .Exists(s) Then  
                   a(.Item(s), 1) = Empty  
                   a(i, 2) = Empty  
                   .Remove (s)  
               End If  
           Next  
 
           [a1].Resize(UBound(a, 1), 2) = a
 
       End With  
   Next  
End Sub
 
 
 
#16
25.04.2012 21:52:27
По просьбе трудящихся чуть изменил код.  
Теперь тут крутится бесконечный цикл - до тех пор, пока есть повторы (а то был пример, где 26 циклов понадобилось...)  
 
 
Sub DoublesRemoveTwoColumns()  
   Dim a, i&, s, x&, flag As Boolean  
 
   Do  
   x = x + 1  
       With CreateObject("Scripting.Dictionary")  
           ' .CompareMode = 1  
 
           a = Intersect(ActiveSheet.UsedRange, [a:b]).Value
 
           flag = False  
           For i = 1 To UBound(a, 1)  
               If Len(Trim(a(i, 1))) Then .Item(a(i, 1)) = i  
           Next  
 
 
           For i = 1 To UBound(a, 1)  
               s = a(i, 2)  
               If .Exists(s) Then  
                   flag = True  
                   a(.Item(s), 1) = Empty  
                   a(i, 2) = Empty  
                   .Remove (s)  
               End If  
           Next  
 
           If Not flag Then  
               MsgBox "Повторяющиеся данные закончились за " & x & " циклов.", vbInformation  
               Exit Do  
           End If  
 
           [a1].Resize(UBound(a, 1), 2) = a
 
       End With  
   Loop  
 
End Sub
 
 
 
#17
25.04.2012 23:00:36
С удалением пустых вверх - т.е. оставшиеся собираются в кучку:  
 
 
Sub DoublesRemoveTwoColumns()  
   Dim a, i&, s, x&, flag As Boolean  
 
   Application.ScreenUpdating = False  
   On Error Resume Next  
     
   Do  
       x = x + 1  
       With CreateObject("Scripting.Dictionary")  
           ' .CompareMode = 1  
 
           a = Intersect(ActiveSheet.UsedRange, [a:b]).Value
 
           flag = False  
           For i = 1 To UBound(a, 1)  
               If Len(Trim(a(i, 1))) Then .Item(a(i, 1)) = i  
           Next  
 
 
           For i = 1 To UBound(a, 1)  
               s = a(i, 2)  
               If .Exists(s) Then  
                   flag = True  
                   a(.Item(s), 1) = Empty  
                   a(i, 2) = Empty  
                   .Remove (s)  
               End If  
           Next  
 
           If Not flag Then  
               MsgBox "Повторяющиеся данные закончились за " & x - 1 & " циклов.", vbInformation  
               Exit Do  
           End If  
 
           With [a1].Resize(UBound(a, 1), 2)
               .Value = a  
               .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp  
           End With  
       End With  
   Loop  
 
   On Error GoTo 0  
   Application.ScreenUpdating = True  
End Sub
 
 
 
#18
25.04.2012 23:21:56
Эм.. если сравнивать текст - то стОит раскомментировать строку  
' .CompareMode = 1  
Тогда регистр не будет играть роли.  
 
Ну и может быть ещё стОит добавить trim()  
сюда  
If Len(Trim(a(i, 1))) Then .Item(Trim(a(i, 1))) = i  
и сюда  
s = Trim(a(i, 2))  
 
Это если пробел спереди/сзади не должен отличать строки.
 
 
 
Страницы: 1
Читают тему
Наверх