Макрос не правильно работает

[staniiislav]

Доброго времени суток, Ув. форумчане!
Почти дописал макрос, все вроде хорошо, но есть одна проблема

Private Sub Worksheet_Change(ByVal Target As Range) ' Отслеживать событие изменения/внесения данных
If Not Application.Intersect(Target, Range("C4:C34")) Is Nothing Then
On Error GoTo EndMacro
If Target.Value <> "" Then
Dim i&, r%, c%
    r = ActiveCell.Row          'Определение активной строки
    c = ActiveCell.Column       'Определение активного столбца
    With Application                ' С приложением
        .EnableEvents = False           ' отключить обработку событий
        With Target                     ' С ячекой
            If .Count = 1 Then              ' Кол-во измененных ячеек не более 1-ой?
                For i = r To Application.InputBox("Введите количество дней", "ВНИМАНИЕ!!!", Type:=1) + r
                    If Cells(i, 2) <> 0 Then
                        Cells(i - r + r, c).Value = .Value  ' Записать значение
                    End If
                Next
            End If
        End With
        .EnableEvents = True            ' включить обработку событий
    End With
End If
End If
Exit Sub
EndMacro:
End Sub

в коде, где выделено красным не правильно работает копирование. Суть в чем, по второму столбцу просматриваю если значение <>0 то в копировать активную ячейку вниз по активному столбцу, если =0 не копировать. Все работает только когда я задаю допустим копировать на 5 ячеек вниз по активному столбцу и если в столбце 2 попадается допустим одна ячейка со значение =0, то макрос не копирует конечно, но и в следующую ячейку после пустой не добавляет тоже. Вообщем получается вместо 5 скопированных ячеек, только 4.
Как это можно подправить? И правильно ли я написал синтаксис макроса?
Спасибо!

[Казанский]

Пробуйте .

[staniiislav]

Сообщение от Казанский

Пробуйте .

Спасибо огромное!

Вот что получилось:

Private Sub Worksheet_Change(ByVal Target As Range) ' Отслеживать событие изменения/внесения данных
If Not Application.Intersect(Target, Range("C6:CX4155")) Is Nothing Then
On Error GoTo EndMacro
If Target.Value <> 0 Then
Dim i&, r%, c%, j&
    r = ActiveCell.Row          'Определение активной строки
    c = ActiveCell.Column       'Определение активного столбца
    With Application                ' С приложением
        .EnableEvents = False           ' отключить обработку событий
        With Target                     ' С ячекой
            If .Count = 1 Then              ' Кол-во измененных ячеек не более 1-ой?
                j = Application.InputBox("Введите количество дней", "ВНИМАНИЕ!!!", Type:=1)
                For i = r + 1 To 4155 'последняя строка!
                    If Cells(i, 2) <> 0 Then
                        Cells(i - r + r, c).Value = .Value  ' Записать значение
                        j = j - 1
                        If j = 0 Then Exit For
                    End If
                Next
            End If
        End With
        .EnableEvents = True            ' включить обработку событий
    End With
End If
End If
Exit Sub
EndMacro:
End Sub

я выделил красным, то что я изменил. А обязательно объявлять последнюю строку? И почему вы переместили For i = r + 1 To 4155? И чем вам не понравился вот этот цикл For i = r + 1 To r + j + 1?
Спасибо!

[Казанский]

> чем вам не понравился вот этот цикл For i = r + 1 To r + j + 1?

Тем, что мы не знаем, до какой строки вниз надо будет пройти. Из-за наличия пустых ячеек номер этой строки больше, чем r + j + 1.
С другой стороны, нельзя просто идти и идти вниз пока j не станет равным 0. Потому что если макрос запустить внизу таблицы, заполненных ячеек в ст. В может не хватить. Поэтому выход из цикла происходит либо по достижению последней строки таблицы, либо по заполнению заданного числа ячеек (j = 0).

Последнюю строку можно определять программно:

For i = r + 1 To Cells(Rows.Count, 2).End(xlUp).Row 'последняя строка

[Казанский]

Да, и замените

Cells(i - r + r, c)

на

Cells(i, c)

Первый класс, однако

[staniiislav]

Сообщение от Казанский

Да, и замените

Cells(i - r + r, c)

на

Cells(i, c)

Первый класс, однако

Спасибо огромное! )))))

[staniiislav]

Private Sub Worksheet_Change(ByVal Target As Range) ' Отслеживать событие изменения/внесения данных
If Not Application.Intersect(Target, Range("C6:CX4155")) Is Nothing Then
On Error GoTo EndMacro
If Target.Value <> 0 Then
Dim i&, r%, c%, j&
    r = ActiveCell.Row          'Определение активной строки
    c = ActiveCell.Column       'Определение активного столбца
    With Application                ' С приложением
        .EnableEvents = False           ' отключить обработку событий
        With Target                     ' С ячекой
            If .Count = 1 Then              ' Кол-во измененных ячеек не более 1-ой?
                j = Application.InputBox("Введите количество дней", "ВНИМАНИЕ!!!", Type:=1)
                If j <> 0 Then
                    For i = r + 1 To Cells(Rows.Count, 2).End(xlUp).Row 'последняя строка To 4155!
                        If Cells(i, 2) <> 0 Then
                            Cells(i, c).Value = .Value   ' Записать значение
                             j = j - 1
                            If j = 0 Then Exit For
                        End If
                    Next
                End If
            End If
        End With
        .EnableEvents = True            ' включить обработку событий
    End With
End If
End If
Exit Sub
EndMacro:
End Sub

вот что еще нужно было вставить, или при нажатии отмена, копировало до последней ячейки! )))
Еще раз спасибо Казанский!