Страницы: 1 2 След.
RSS
Необходимо удалить пару дублирующих записей.
 
Краткая суть из 1-ой темы.  
Есть большая таблица (~100 тыс строк), суммы с плюсом и минусом, необходимо удалить пару дублирующих цифр, но только пару. По сути - операции сторно в бух. учете.  
Все числа необходимо оставить на их местаю и кроме пар +,- ничего не удалять.  
Тут есть одна проблема..можно удалять пары -,+ только в одном субсчете, т.е. есть два диапазона, если совпадают цифры в 1 диапазоне, то пары +,- в этих строчках можно удалять из 2-го диапазона(но лучше выделить цветом, как показала практика)  
 
Hugo можно ли с Вами пообщаться не на форуме, возможно по icq.  
 
Модераторы, такого больше не повториться, прошу тему не закрывать :)
 
Option Explicit  
 
Sub DoublesRemove()  
   Dim a, i&, s$, ss$  
   a = Range([B1], Range("E" & Rows.Count).End(xlUp)).Value
 
   With CreateObject("Scripting.Dictionary")  
       ' .CompareMode = 1  
       For i = 2 To UBound(a, 1)  
           s = a(i, 1) & "|" & a(i, 4)  
           ss = a(i, 1) & "|" & -a(i, 4)  
           If Not .Exists(ss) Then  
               .Item(s) = i  
           Else  
               a(.Item(ss), 1) = Empty  
               a(.Item(ss), 4) = Empty  
               a(i, 1) = Empty  
               a(i, 4) = Empty  
               .Remove (ss)  
           End If  
       Next  
   End With  
 
   [g1:j1].Resize(UBound(a, 1)) = a
 
End Sub  
 
 
Так изменённый массив выгрузится рядом.  
Можно вместо Empty писать какое-нибудь слово.  
 
IСQ нет, почта в подписи, но только вечером.
 
Про нули забыл - добавьте в цикле первой строкой условие, что если a(i, 4)<>0 то...
 
У меня так же возникла необходимость удаления сторно.  
нужно чтобы цифра с противоположенным знаком удалялась в соседнем диапазоне, например : в диапазоне 1 есть цифра 200 а в диапазоне 2 есть цифра -200, они то и должны удалятся меж собой. а так как в этом макросе не правильно что противоположенные цифры удаляются в одном диапазоне.  
 
диапазоны должны быть именно соседними (диапазон 201-202, 241-242, 953-954 итд), если уже повторяющееся противоположенное значение в диапазонах 201 и 242 то они не должны удалятся  
 
прошу ответа
Zhuldyz
 
Я ведь говорил, что вопросы идут косяками :)  
На неделе это уже кажется третий вопрос по этой теме.  
 
Про диапазоны не понял - давайте покажите небольшой(!) файл.  
 
P.S. А BoxA не отписался, не поблагодарил/прокомментировал... Нужно запомнить...  
Или может случилось что с человеком? :(
 
здесь если Сумма ВВ =0 то строку удалить (что я сделала макросом)  
фильтром выбираю ВидДвижения 025-026 и удаляю строки где "2600" и "-2600" итд, затем фильтром выбираю ВидДвижения 101-102 и удаляю строки где "91200" и "-91200" итд, затем выбираю ВидДвижения 201-202, 241-242, ..., 953-954. Все кроме Вида Движения 415-416 - Строки с таким видом движения переношу вниз таблицы, оставляя пустыми 2-3 строки.
Zhuldyz
 
Эти пары "видов движения" заранее известны и постоянны?  
Почему не нужно обрабатывать 415-416 - потому что это исключение и всегда так будет?  
 
Можно подумать - но ничего не обещаю. Если ещё кому интересно - подключайтесь.
 
Эти пары известны но их много, прилепляю файл с видами движения
 
А Z41 кому пара?  
Т.е. я понял так - в этом файле пары расположены последовательно 1-2, 3-4, ... 15-16, 19-20?  
 
Серьёзная работа...
 
На счет 415-416 да так будет всегда , строки с этими видами движения нужно переносить вниз списка через 2-3 пустые строки  
И еще забыла сказать что при удалении строк материал должен быть один и тот же. например: строку с материалом 110043712 с видом движения 101 с Суммой ВВ 200, могу удалить со строкой где материал тот же 110043712 с видом движения 102 с Суммой ВВ -200
 
Z41 пара Z42 , не добавила , sorry  
да пары идут последовательно
Zhuldyz
 
Вроде что-то придумывается потихоньку...  
Как видно, в пределах одного ВидДвижения не может быть пар на удаление? Т.е. это отслеживать не нужно - можно объединять все сделки пары ВидДвижения/Материал в одну группу и взаимно удалять.  
Значит нужно всего лишь преобразовать эти пары в одно одинаковое обозначение, и можно использовать уже ранее мною написанный код (там только подправить диапазоны, место выгрузки, ну и ещё чуть по мелочи, словарь и может быть ещё один массив добавить :)).  
Затем пройтись циклом и удалить строки без значений в ячейках.  
Вот с 415-416 как-то туманно - пропуск пока не продумал, и перенос думаю можно сделать или вручную, или потом дописать отдельный блок на эту работу.
 
из файла виды движения удалила 2 лишних вида движения : 125 и 350,    
тогда получится по парам правильно, как вы предположили
Zhuldyz
 
Да, в пределах одного ВидДвижения не может быть пар на удаление
Zhuldyz
 
Они ведь одинаковые, эти файлы - и оба без Z42 :(  
125 - согласен, лишнее.  
А 350 нет - тогда уж и 349 нуно удалять.  
Проверьте тщательно список ещё раз - время есть вероятно до вечера, или до воскресентя :(
 
344 лишнее. Проверял формулами.
 
Проверьте.  
Строки можете вручную удалить фильтром по суммам - выбрать "del".  
Ну и перенос вниз тоже не делал.  
Вместо "C:\Temp\Zhuldyz_pars.xls" подставьте свой путь к файлу с парами "движений".  
Код лучше копировать из окна "цитировать" - там отступы видны.  
 
Sub DoublesRemove()  
 
 
   Dim fso As Object  
   Dim ts As Object  
   Dim arr  
   Dim a, i&, s$, ss$  
   Dim DvDic As Object  
 
   Set fso = CreateObject("Scripting.FileSystemObject")  
 
   'файл  
   Set ts = fso.OpenTextFile("C:\Temp\Zhuldyz_pars.xls", 1)    'Подставьте свой путь к файлу  
   arr = Split(ts.ReadAll, vbCrLf)    'массив строк текста целиком  
   'начало пар в чётной строке, начиная с №2 (0 и 1 пропускаем)  
 
   Set ts = Nothing  
   Set fso = Nothing  
 
   Set DvDic = CreateObject("scripting.dictionary")  
 
   With DvDic  
       .CompareMode = 1  
       For i = 3 To UBound(arr)  
           If i Mod 2 = 1 Then  
               .Item(Format(arr(i - 1), "000")) = Format(arr(i - 1), "000") & "|" & Format(arr(i), "000")  
               .Item(Format(arr(i), "000")) = Format(arr(i - 1), "000") & "|" & Format(arr(i), "000")  
           End If  
       Next  
       .Remove ("415"): .Remove ("416") 'эти удаляем из словаря  
   End With  
 
   a = Range([A1], Range("C" & Rows.Count).End(xlUp)).Value
 
   With CreateObject("Scripting.Dictionary")  
        .CompareMode = 1  
       For i = 2 To UBound(a, 1)  
           If a(i, 3) <> 0 Then 'отбираем с суммами  
           If DvDic.exists(CStr(a(i, 2))) Then 'отбираем те, которые нужно отбирать :)  
               s = a(i, 1) & "|" & DvDic.Item(CStr(a(i, 2))) & "|" & a(i, 3)  
               ss = a(i, 1) & "|" & DvDic.Item(CStr(a(i, 2))) & "|" & -a(i, 3)  
               If Not .exists(ss) Then  
                   .Item(s) = i  
               Else  
                   a(.Item(ss), 3) = "del"  
                   a(i, 3) = "del"  
                   .Remove (ss)  
               End If  
               End If  
           End If  
       Next  
   End With  
 
   [A1:C1].Resize(UBound(a, 1)) = a
 
End Sub
 
Не работает, во первых высвечивает желтым .Remove ("415"): .Remove ("416") 'эти удаляем из словаря. А когда заглушаю эту строку, при запуске макроса ничего не меняется, просто мигает и все (((
Zhuldyz
 
C:\Temp\Zhuldyz_pars.xls есть? В словарь загрузился?  
В том файле я удалил лишнее и добавил недостающее.
 
Если не поняли, что это за файл - это Ваш с парами. Прикрепил (название конечно можно дать любое, лишь бы в коде тоже оно было :) )
 
Да, можно для проверки выгружать не в    
[A1:C1].Resize(UBound(a, 1)) = a
а например в  
[F1:H1].Resize(UBound(a, 1)) = a
Тогда увидите, какие суммы заменит на del.  
Вообще там ещё есть что "подкрутить" - просто уже убегал с работы, а сейчас уже скоро убегаю из дома :)
 
а как можно вместо того чтобы писать del вообще удалить строку всю
 
А Вы сейчас поставьте фильтр по del, выделите все и удалите.  
Ну а если делать кодом - то нужно дальше дописать такой блок.  
Есть много примеров удаления строк - можно вместо del ставить Empty и удалять все пустые в этой ячейки строки.  
Или ещё что-то придумать - на 100 000 строк нужно сделать как-то быстро...  
Если можно таблицу сортировать - то есть решение, хотя и руками недолго: отсортировали по del, выделили блок, удалили.
 
Сразу удалять вместо "писания" нельзя.
 
Есть вариант неплохой...
 
Okey, блок на удаление напишу сама.
Zhuldyz
 
Вот так, используя 4-ый пустой столбец, должно быть быстро.  
 
Sub DoublesRemove()  
 
 
   Dim fso As Object  
   Dim ts As Object  
   Dim arr  
   Dim a, i&, s$, ss$  
   Dim DvDic As Object  
 
   Set fso = CreateObject("Scripting.FileSystemObject")  
 
   'файл  
   Set ts = fso.OpenTextFile("C:\Temp\Zhuldyz_pars.xls", 1)    'Подставьте свой путь к файлу  
   arr = Split(ts.ReadAll, vbCrLf)    'массив строк текста целиком  
   'начало пар в чётной строке, начиная с №2 (0 и 1 пропускаем)  
 
   Set ts = Nothing  
   Set fso = Nothing  
 
   Set DvDic = CreateObject("scripting.dictionary")  
 
   With DvDic  
       .CompareMode = 1  
       For i = 3 To UBound(arr)  
           If i Mod 2 = 1 Then  
               .Item(Format(arr(i - 1), "000")) = Format(arr(i - 1), "000") & "|" & Format(arr(i), "000")  
               .Item(Format(arr(i), "000")) = Format(arr(i - 1), "000") & "|" & Format(arr(i), "000")  
           End If  
       Next  
       .Remove ("415"): .Remove ("416")    'эти удаляем из словаря  
   End With  
 
   a = Range([A1], Range("C" & Rows.Count).End(xlUp)).Value
   ReDim b(1 To UBound(a), 1 To 1)  
 
   With CreateObject("Scripting.Dictionary")  
       .CompareMode = 1  
       For i = 2 To UBound(a, 1)  
           If a(i, 3) <> 0 Then    'отбираем с суммами  
               If DvDic.exists(CStr(a(i, 2))) Then    'отбираем те, которые нужно отбирать :)  
                   s = a(i, 1) & "|" & DvDic.Item(CStr(a(i, 2))) & "|" & a(i, 3)  
                   ss = a(i, 1) & "|" & DvDic.Item(CStr(a(i, 2))) & "|" & -a(i, 3)  
                   If Not .exists(ss) Then  
                       .Item(s) = i  
                   Else  
                       b(.Item(ss), 1) = CVErr(xlErrNA)  
                       b(i, 1) = CVErr(xlErrNA)  
                       .Remove (ss)  
                   End If  
               End If  
           End If  
       Next  
   End With  
 
   [D1].Resize(UBound(b, 1)) = b
 
   With ActiveSheet.UsedRange.Columns(4)  
       .SpecialCells(xlCellTypeConstants, xlErrors).Delete Shift:=xlUp  
   End With  
 
End Sub
 
{quote}{login=Hugo}{date=07.09.2012 08:52}{thema=}{post}Есть вариант неплохой...{/post}{/quote}  
ждус
 
Эмм, поторопился - удалять надёжнее так:  
 
 
   With ActiveSheet.UsedRange.Columns(4)  
       .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete Shift:=xlUp  
   End With  
 
 
Хотя и так, как выше в коде, тоже почему-то работает на всю строку... :)  
Всё, убегаю на пару часиков...
 
Обалденно  получилось! Спасибо Большое!
Zhuldyz
Страницы: 1 2 След.
Наверх