Страницы: 1
RSS
Перестало работать автозаполнение формул по двойному клику
 
Здравствуйте, уважаемые форумчане. Столкнулся с следующей проблемой в данном файле на листе "лист1" столбец А был заполнен формулами(=ЕСЛИ(СЧЁТЗ('Участок № 491 БД'!C3);ТЕКСТ('Участок № 491 БД'!C3;"ММММ ГГГГ");"")) до конца, а потом с помощью удалить дубликаты оставались только уникальные значения. Так вот еще вчера все работало как надо, но почему-то сегодня данный столбец ( а нужен он для динамического списка) перестал работать как надо, функция мгновенное заполнение не хочет работать ни в каком виде (двойной клик по крестику или через работу с данными). Файл по каким-то непонятным причинам раздуло до размеров в 5 мегабайт, по этому делюсь им через гугл диск https://drive.google.com/open?id=1nt1TxQjJQPdts5o8ljGdjilgnrY9Jlz-
 
Цитата
FastPuppy написал: столбец А был заполнен формулами..... до конца
Т.е. до последней, до 1 048 576 строки? А это точно необходимо? Удалил в Вашем файле на Листе1 эти неиспользуемые строки. Размер 22 Кб. И все автозаполняется
Согласие есть продукт при полном непротивлении сторон
 
До последний не обязательно конечно, но без столбца, который сначала выдергивает месяц из колонки даты на листе БД, а потом создает аналогичный без повторений месяца, у меня не получится создать динамический список на листе Участок №491. К слову почему-то расширенный фильтр с проблемой справиться не помогает, выдавая ошибку "ссылка". Короче я худо бедно смог решить задачу взяв макрос (вроде даже с вашего сайта)
Код
Function Уник(ByVal ra As Range) As Variant     On Error Resume Next: Dim cell As Range, coll As New Collection, txt$     For Each cell In ra.Cells         txt$ = Trim(cell): If Len(txt$) Then coll.Add txt$, txt$     Next cell     ReDim newarr(1 To coll.Count, 1 To 1)     For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i     Уник = newarr End Function 

Попробовал написать свой макрос на копирование уникальных ячеек до тех пор пока не появится пустая ячейка, но чет напортачил

 

Код
Sub Test2()      '      ActiveSheet.Cells(1, 4).Select      i = 1      Do Until IsEmpty(ActiveCell)         If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then         ActiveCell.Offset(1, 0).Select         Else         Selection.Copy ActiveSheet.cell(i, 1)         i = i + 1         End If        ActiveCell.Offset(1, 0).Select      Loop   End Sub

Изменено: FastPuppy - 26.12.2017 11:29:43
 
Макрос написал, тему можно закрывать
Страницы: 1
Читают тему
Наверх