Помогите, пожалуйста исправить макрос на получение адресов ячеек относительно активной ячейки и вставки формул в соответствующие ячейки.
Количество добавляемых строк изменяется отноительно активной по фомуле: число активной ячейки -2. соответственно может быть разное количество добавленых строк Спасибо за стремление помочь, вроде разобрался [vba]
Код
Dim p& For p = 1 To b Step 1 g = p * 2 - 1 range(d).Offset(, -4).Activate Selection.End(xlUp).Offset(g).Select Z = ActiveCell.Address range(d).Offset(p, 3).Formula = "=" & Z Next p
[/vba]
Если, кто-то предложит более интересный вариант - буду благодарен.
Добрый день.
Помогите, пожалуйста исправить макрос на получение адресов ячеек относительно активной ячейки и вставки формул в соответствующие ячейки.
Количество добавляемых строк изменяется отноительно активной по фомуле: число активной ячейки -2. соответственно может быть разное количество добавленых строк Спасибо за стремление помочь, вроде разобрался [vba]
Код
Dim p& For p = 1 To b Step 1 g = p * 2 - 1 range(d).Offset(, -4).Activate Selection.End(xlUp).Offset(g).Select Z = ActiveCell.Address range(d).Offset(p, 3).Formula = "=" & Z Next p
[/vba]
Если, кто-то предложит более интересный вариант - буду благодарен.berya
В код особо не вникал, но вроде так надо (если я задачу правильно понял): [vba]
Код
Dim p&, b, g b = ActiveCell.Value - 2 For p = 1 To b g = p * 2 - 1 ActiveCell.Offset(, -4).End(xlUp).Offset(g).Activate ActiveCell.Offset(p, 3).Value = ActiveCell.Address Next p
[/vba]
В код особо не вникал, но вроде так надо (если я задачу правильно понял): [vba]
Код
Dim p&, b, g b = ActiveCell.Value - 2 For p = 1 To b g = p * 2 - 1 ActiveCell.Offset(, -4).End(xlUp).Offset(g).Activate ActiveCell.Offset(p, 3).Value = ActiveCell.Address Next p
Application.ScreenUpdating = False With ActiveCell r = .Value - 2 If r <= 0 Then Exit Sub ' достаточно одной проверки .Offset(1).Resize(r).EntireRow.Insert With .Offset(1, 1).Resize(r) ' присваиваем сразу всем (без цикла) .Font.Size = 16 .Font.ThemeColor = 5 .Value = "Переможець бою №" End With .Offset(, -4).Resize(r + 1, 14).Borders.LineStyle = 1 ' не понял зачем вам это, но оставил, чтобы не нарушать вашу логику n = 1 ' начальное смещение по строкам, относительно шапки таблицы For r = 1 To r .Offset(r, 3).Formula = "=" & Cells(4, 3).Offset(n).Address 'MsgBox "Адрес об'единённого диапазона : " & Cells(4, 3).Offset(n).MergeArea.Address n = n + Cells(4, 3).Offset(n).MergeArea.Rows.Count ' смещение на следующую объединенную ячейку Next End With Application.ScreenUpdating = True End Sub
[/vba]
так надо? [vba]
Код
Sub Str() Dim r&, n&
Application.ScreenUpdating = False With ActiveCell r = .Value - 2 If r <= 0 Then Exit Sub ' достаточно одной проверки .Offset(1).Resize(r).EntireRow.Insert With .Offset(1, 1).Resize(r) ' присваиваем сразу всем (без цикла) .Font.Size = 16 .Font.ThemeColor = 5 .Value = "Переможець бою №" End With .Offset(, -4).Resize(r + 1, 14).Borders.LineStyle = 1 ' не понял зачем вам это, но оставил, чтобы не нарушать вашу логику n = 1 ' начальное смещение по строкам, относительно шапки таблицы For r = 1 To r .Offset(r, 3).Formula = "=" & Cells(4, 3).Offset(n).Address 'MsgBox "Адрес об'единённого диапазона : " & Cells(4, 3).Offset(n).MergeArea.Address n = n + Cells(4, 3).Offset(n).MergeArea.Rows.Count ' смещение на следующую объединенную ячейку Next End With Application.ScreenUpdating = True End Sub
Доброе вркмя суток. В макросе от KSV есть недаработка в ввиде привязки к постоянной ячейке - Cells(4, 3). В настоящее время этот макрос уже переделан и выполняетя. Большое спасибо всем, кто проявил внимание и участие в этой теме.
Доброе вркмя суток. В макросе от KSV есть недаработка в ввиде привязки к постоянной ячейке - Cells(4, 3). В настоящее время этот макрос уже переделан и выполняетя. Большое спасибо всем, кто проявил внимание и участие в этой теме.berya