Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Протягивание формул с помощью макроса
 
#1
21.11.2018 15:20:45
Здравствуйте! Помогите написать макрос для протягивания формул. Прикрепляю файл для примера, количество строк может доходить до 100к. Интервалы между ячейками(с черным цветом) непостоянные. Ячейки(с красным текстом) нужно протянуть до следующего значения в столбце.  
 
 
 
#2
21.11.2018 15:40:59
serega1705, если изначально области между строками пустые
Код
Sub Se()
Dim a As Range, n&
  For Each a In Range("A:E").SpecialCells(xlCellTypeBlanks).Areas
    n = a.Row - 1
    a.FormulaR1C1 = Array("=R[-1]C+R" & n & "C3", "=R[-1]C+R" & n & "C4", "", "", "=R[-1]C+R" & n & "C6")
  Next
End Sub
Изменено: Казанский - 21.11.2018 15:41:35
 
 
 
#3
21.11.2018 21:26:07
Цитата
serega1705 написал:
количество строк может доходить до 100к.
В таком случае уходите от формул.
 
 
 
#4
22.11.2018 06:59:18
Кнопка цитирования не для бездумного копирования [МОДЕРАТОР]

Казанский, он создает дополнительные значения в столбцах С и D, в F не создает, но в формуле ячейки Е2 и далее использует пустую ячейку F2. И сразу с А3, В3 и Е3 формула изменяется. То же, происходит в других интервалах , после строк с ячейками черного цвета.
 
 
 
#5
22.11.2018 12:05:42
serega1705, а, значит формулы в строках ниже констант существуют? Тогда проще их убрать и вставить как в #2
Код
Sub Se()
Dim a As Range, n&
  Range("A:E").SpecialCells(xlCellTypeFormulas).ClearContents
  For Each a In Range("A:E").SpecialCells(xlCellTypeBlanks).Areas
    n = a.Row - 1
    a.FormulaR1C1 = Array("=R[-1]C+R" & n & "C3", "=R[-1]C+R" & n & "C4", "", "", "=R[-1]C+R" & n & "C6")
  Next
End Sub
 
 
 
#6
22.11.2018 13:09:47
И сразу с А3, В3 и Е3 формула изменяется, первый аргумент перескакивает через одну ячейку. Сам пытался поправить, не могу найти, что исправить или добавить.
 
 
 
#7
22.11.2018 16:54:58
Цитата
serega1705 написал:
формула изменяется, первый аргумент перескакивает через одну ячейку
Да, странный эффект, похоже на баг в Excel.
Можно копировать существующие формулы, так даже проще
Код
Sub Se1()
Dim a As Range
  For Each a In Range("A:A").SpecialCells(xlCellTypeBlanks).Areas
    a.Cells(0, 1).Resize(, 5).Copy a
  Next
End Sub
 
 
 
#8
23.11.2018 06:46:07
Спасибо большое, все работает!
 
 
 
Страницы: 1
Наверх