Roman777, распакуйте из скачанного файла архиватором файл xlmacr8.hlp и если у вас win 7, то для его открытия потребуется программа, если XP, то открывается двойным тыком
Roman777, распакуйте из скачанного файла архиватором файл xlmacr8.hlp и если у вас win 7, то для его открытия потребуется программа, если XP, то открывается двойным тыкомkrosav4ig
Выделить диапазон, Ctrl+H, в поле Найти 0,поле заменить на оставить пустым>кнопка подробнее>>, поставить галочку ячейка целиком, заменить все F5>Выделить>пустые ячейки>ок>Ctrl+->ячейки со сдвигом вверх>ок
Выделить диапазон, Ctrl+H, в поле Найти 0,поле заменить на оставить пустым>кнопка подробнее>>, поставить галочку ячейка целиком, заменить все F5>Выделить>пустые ячейки>ок>Ctrl+->ячейки со сдвигом вверх>окkrosav4ig
VEKTORVSFREEMAN, добрый день, дело в том, что при пересчете итеративные формулы с нуля не пересчитываются, нужно вручную перевводить формулу и жать F9 или использовать макрос для их пересчета. И в формулу забыл добавить проверку на ошибки. Заменил формулу в имени на
это имя нужно для работы макроса макрос в модуле листа при изменении ячеек включает итеративные вычисления и пересчитывает все итеративные формулы, которые ссылаются измененные ячейки
[vba]
Код
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Application: .DisplayAlerts = 0: .Iteration = 0 If Me.CircularReference Is Nothing Then .DisplayAlerts = 1: Exit Sub Else Dim dic: Set dic = CreateObject("scripting.dictionary") Dim cell As Range, rngRef As Range Set rngRef = Nothing For Each cell In Me.UsedRange.SpecialCells(xlCellTypeFormulas) If Not Intersect(cell.Precedents.Cells, cell) Is Nothing Then dic(cell.Address) = cell.Precedents.Address If rngRef Is Nothing Then Set rngRef = cell.Precedents _ Else Set rngRef = Union(rngRef, cell.Precedents) End If Next cell Dim rngAC As Range, rngSel As Range, strAddr Set rngSel = Selection: Set rngAC = ActiveCell If Intersect(rngRef, Target) Is Nothing Then GoTo lb .ScreenUpdating = 0: .EnableEvents = 0: .Iteration = 1 For Each strAddr In dic.keys .ScreenUpdating = 0: .EnableEvents = 0: If Not Intersect(Range(dic(strAddr)), Target) Is Nothing Then With Range(strAddr) .Select: .Replace "=", "=" Do: .Calculate: Loop Until [check] End With End If Next rngSel.Select: rngAC.Activate lb: .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With Set dic = Nothing Set cell = Nothing: Set rngRef = Nothing: Set rngAC = Nothing: Set rngSel = Nothing End Sub
[/vba]
добавил в файл еще 1 вариант (макрофункцию) [p.s.]Ну не сдержался я, написал макрос [/p.s.] [offtop]
Цитата
добрый день
ну или вечер...
VEKTORVSFREEMAN, добрый день, дело в том, что при пересчете итеративные формулы с нуля не пересчитываются, нужно вручную перевводить формулу и жать F9 или использовать макрос для их пересчета. И в формулу забыл добавить проверку на ошибки. Заменил формулу в имени на
это имя нужно для работы макроса макрос в модуле листа при изменении ячеек включает итеративные вычисления и пересчитывает все итеративные формулы, которые ссылаются измененные ячейки
[vba]
Код
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Application: .DisplayAlerts = 0: .Iteration = 0 If Me.CircularReference Is Nothing Then .DisplayAlerts = 1: Exit Sub Else Dim dic: Set dic = CreateObject("scripting.dictionary") Dim cell As Range, rngRef As Range Set rngRef = Nothing For Each cell In Me.UsedRange.SpecialCells(xlCellTypeFormulas) If Not Intersect(cell.Precedents.Cells, cell) Is Nothing Then dic(cell.Address) = cell.Precedents.Address If rngRef Is Nothing Then Set rngRef = cell.Precedents _ Else Set rngRef = Union(rngRef, cell.Precedents) End If Next cell Dim rngAC As Range, rngSel As Range, strAddr Set rngSel = Selection: Set rngAC = ActiveCell If Intersect(rngRef, Target) Is Nothing Then GoTo lb .ScreenUpdating = 0: .EnableEvents = 0: .Iteration = 1 For Each strAddr In dic.keys .ScreenUpdating = 0: .EnableEvents = 0: If Not Intersect(Range(dic(strAddr)), Target) Is Nothing Then With Range(strAddr) .Select: .Replace "=", "=" Do: .Calculate: Loop Until [check] End With End If Next rngSel.Select: rngAC.Activate lb: .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With Set dic = Nothing Set cell = Nothing: Set rngRef = Nothing: Set rngAC = Nothing: Set rngSel = Nothing End Sub
[/vba]
добавил в файл еще 1 вариант (макрофункцию) [p.s.]Ну не сдержался я, написал макрос [/p.s.] [offtop]
поставил напротив Симонова отметку "снят" данные из первой строки полностью исчезли
похоже, что у вас отключены макросы в параметрах безопасности, у меня на всех компах все пересчитывается и возвращаются правильные значения добавил комментарии в макрос, авось где-нить пригодится
[vba]
Код
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Application: .DisplayAlerts = 0: .Iteration = 0 'если нет итеративных формул, выйти из процедуры If Me.CircularReference Is Nothing Then .DisplayAlerts = 1: Exit Sub Else 'создаем словарь Dim dic: Set dic = CreateObject("scripting.dictionary") Dim cell As Range, rngRef As Range 'перебираем все ячейки с формулами For Each cell In Me.UsedRange.SpecialCells(xlCellTypeFormulas) 'если диапазон ячейки пересекается с диапазоном влияющих на нее ячеек If Not Intersect(cell.Precedents.Cells, cell) Is Nothing Then 'то добавляем в словарь (адрес диапазона влияющих ячеек) с ключем (адрес ячейки) dic(cell.Address) = cell.Precedents.Address 'и объединяем диапазон влияющих ячеек с диапазоном rngRef If rngRef Is Nothing Then Set rngRef = cell.Precedents _ Else Set rngRef = Union(rngRef, cell.Precedents) End If Next cell Dim rngAC As Range, rngSel As Range, strAddr 'записываем в переменные текущее выделение и активную ячейку Set rngSel = Selection: Set rngAC = ActiveCell 'измененные ячейки не входят в диапазон rngRef, то выйти из процедуры If Intersect(rngRef, Target) Is Nothing Then Exit Sub .ScreenUpdating = 0: .EnableEvents = 0: .Iteration = 1 'перебираем адреса ячеек (strAddr) в ключах словаря For Each strAddr In dic.keys .ScreenUpdating = 0: .EnableEvents = 0: 'если измененные ячейки входят в диапазон соответсвующего элемента словаря (Range(dic(strAddr)) If Not Intersect(Range(dic(strAddr)), Target) Is Nothing Then With Range(strAddr) 'то выделяем ячейку Range(strAddr) и перевводим в ней формулу .Select: .Replace "=", "=" 'пересчитываем ячейку, пока значение имени Check станет равным ИСТИНА Do: .Calculate: Loop Until [check] End With End If Next 'возвращаем выделение и активную ячейку из переменных rngSel.Select: rngAC.Activate lb: .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With 'очищаем переменные Set dic = Nothing Set cell = Nothing: Set rngRef = Nothing: Set rngAC = Nothing: Set rngSel = Nothing End Sub
поставил напротив Симонова отметку "снят" данные из первой строки полностью исчезли
похоже, что у вас отключены макросы в параметрах безопасности, у меня на всех компах все пересчитывается и возвращаются правильные значения добавил комментарии в макрос, авось где-нить пригодится
[vba]
Код
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) With Application: .DisplayAlerts = 0: .Iteration = 0 'если нет итеративных формул, выйти из процедуры If Me.CircularReference Is Nothing Then .DisplayAlerts = 1: Exit Sub Else 'создаем словарь Dim dic: Set dic = CreateObject("scripting.dictionary") Dim cell As Range, rngRef As Range 'перебираем все ячейки с формулами For Each cell In Me.UsedRange.SpecialCells(xlCellTypeFormulas) 'если диапазон ячейки пересекается с диапазоном влияющих на нее ячеек If Not Intersect(cell.Precedents.Cells, cell) Is Nothing Then 'то добавляем в словарь (адрес диапазона влияющих ячеек) с ключем (адрес ячейки) dic(cell.Address) = cell.Precedents.Address 'и объединяем диапазон влияющих ячеек с диапазоном rngRef If rngRef Is Nothing Then Set rngRef = cell.Precedents _ Else Set rngRef = Union(rngRef, cell.Precedents) End If Next cell Dim rngAC As Range, rngSel As Range, strAddr 'записываем в переменные текущее выделение и активную ячейку Set rngSel = Selection: Set rngAC = ActiveCell 'измененные ячейки не входят в диапазон rngRef, то выйти из процедуры If Intersect(rngRef, Target) Is Nothing Then Exit Sub .ScreenUpdating = 0: .EnableEvents = 0: .Iteration = 1 'перебираем адреса ячеек (strAddr) в ключах словаря For Each strAddr In dic.keys .ScreenUpdating = 0: .EnableEvents = 0: 'если измененные ячейки входят в диапазон соответсвующего элемента словаря (Range(dic(strAddr)) If Not Intersect(Range(dic(strAddr)), Target) Is Nothing Then With Range(strAddr) 'то выделяем ячейку Range(strAddr) и перевводим в ней формулу .Select: .Replace "=", "=" 'пересчитываем ячейку, пока значение имени Check станет равным ИСТИНА Do: .Calculate: Loop Until [check] End With End If Next 'возвращаем выделение и активную ячейку из переменных rngSel.Select: rngAC.Activate lb: .ScreenUpdating = 1: .EnableEvents = 1: .DisplayAlerts = 1: End With 'очищаем переменные Set dic = Nothing Set cell = Nothing: Set rngRef = Nothing: Set rngAC = Nothing: Set rngSel = Nothing End Sub
долго порывался сделать эту задачку с помощью Power Query..., вчера сел и вроде что-то получилось для работы должна быть установлена и включена надстройка MS Power Query, в книге должны присутствовать листы: "!" (все листы с исходными данными должны располагаться перед ним, и на этом листе расположена таблица, из которой берется имя файла для запроса),
"Шаблон" (лист-шаблон, на нем сделал 2 сводные, подключенные к подключению, сформированному запросом Power Query),
"Срезы" (Сюда помещаются срезы, которые формируются при выполнении макроса)
при нажатии на кнопку запрос собирает все данные с листов, расположенных до листа "!" и отдает их сводным на листе "Шаблон" и на основании элементов из поля "Класс бетонной смеси" формируются листы по каждому классу, предварительно удалив все листы между "!" и "Шаблон" при установке фильтра в любой сводной на этих листах, он распространяется на вторую сводную на листе
данные в сводных отображаются только из последнего сохранения файла, т.е. при обновлении сводной нужно сохранить файл, при обновлении любой сводной все остальные обновляются автоматически
Upd. Заменил файлы, была небольшая ошибочка
долго порывался сделать эту задачку с помощью Power Query..., вчера сел и вроде что-то получилось для работы должна быть установлена и включена надстройка MS Power Query, в книге должны присутствовать листы: "!" (все листы с исходными данными должны располагаться перед ним, и на этом листе расположена таблица, из которой берется имя файла для запроса),
"Шаблон" (лист-шаблон, на нем сделал 2 сводные, подключенные к подключению, сформированному запросом Power Query),
"Срезы" (Сюда помещаются срезы, которые формируются при выполнении макроса)
при нажатии на кнопку запрос собирает все данные с листов, расположенных до листа "!" и отдает их сводным на листе "Шаблон" и на основании элементов из поля "Класс бетонной смеси" формируются листы по каждому классу, предварительно удалив все листы между "!" и "Шаблон" при установке фильтра в любой сводной на этих листах, он распространяется на вторую сводную на листе
данные в сводных отображаются только из последнего сохранения файла, т.е. при обновлении сводной нужно сохранить файл, при обновлении любой сводной все остальные обновляются автоматически
Upd. Заменил файлы, была небольшая ошибочкаkrosav4ig
Друзья, большое спасибо за такие теплые слова, очень приятно :), буду стараться им соответствовать Виктор, примите и от меня поздравление с пожеланием всего самого наилучшего!
Друзья, большое спасибо за такие теплые слова, очень приятно :), буду стараться им соответствовать Виктор, примите и от меня поздравление с пожеланием всего самого наилучшего!krosav4ig