Макрос переноса строк работает не корректно

[Kraimon]

Из-за чего данный макрос может работать не корректно, а именно периодически не переносить строки на другой лист, а заменять?

Private Sub Worksheet_Change(ByVal Target As Range)
With Sheets("Поступили")
.Select
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
.Rows(Target.Row).Copy Sheets("выбыли").Rows(WorksheetFunc tion.CountA(Sheets("выбыли").[a:a]) + 1)
.Rows(Target.Row).Delete
End If
End With
End Sub

[kuklp]

Private Sub Worksheet_Change(ByVal Target As Range)
With Sheets("Поступили")
    .Select
    If Target.Count > 1 Then Exit Sub
    If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
        .Rows(Target.Row).Copy Sheets("выбыли").Rows(WorksheetFunction.CountA(Sheets("выбыли").[b:b]) + 1)
        .Rows(Target.Row).Delete
    End If
End With
End Sub

[Kraimon]

работает, но если немного изменить строчки, добавить пару столбцов, почему-то опять начинает не добавлсять, а заменять. Макрос немного не стабильный.

[Kraimon]

в этой таблице не работает

[kuklp]

Сообщение от Kraimon

работает, но если немного изменить строчки, добавить пару столбцов, почему-то опять начинает не добавлсять, а заменять. Макрос немного не стабильный.

Вы издеваетесь? Перефразируя известную поговорку:"Неча на макрос пенять, если руки кривые":-) Макрос работает правильно. Он считает к-во непустых ячеек во 2-м столбце и прибавляет к этому 1. После этого в строку с таким номером переносит строку из листа 1. Т.е. чтоб он работал как Вам надо в столбце 2 на листе 2 НЕ ДОЛЖНО быть пропусков. Начните наконец вникать в ВБА. А нет, тогда делайте все руками. Не на что будет жаловаться. Чтоб искала последнюю строку независимо от пустых, можно так:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lr&
    lr = Sheets("выбыли").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    With ME
        If Target.Count > 1 Then Exit Sub
        If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
            .Rows(Target.Row).Copy Sheets("выбыли").Rows(lr)
            .Rows(Target.Row).Delete
        End If
    End With
End Sub

[IgorGO]

Начните наконец вникать в ВБА

)))
а сам сколько вникал? ты на что человека толкаешь?

Вы издеваетесь?

Серега, давно пора привыкнуть, что те, кто знают ВБА (больше или меньше) открывают редактор и крапают потихоньку... с ошибками, с экспериментами...
а те, кто этого не знают - не могут сформулировать вопрос, используя ВБА терминологию, и то, что принципиально важно для корректного функционирования макроса, не обязательно будет даже упомянуто при постановке задачи. грамотное ТЗ здесь такая же редкость, как пингвины на северном полюсе.
Успехов!

[Kraimon]

Спасибки все работает, еще 1 вопрос, как-то можно совместить эти два макроса?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&
lr = Sheets("выбыли").Cells.Find(What:=" *", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
With ME
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
.Rows(Target.Row).Copy Sheets("выбыли").Rows(lr)
.Rows(Target.Row).Delete
End If
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D1:F500")) Is Nothing Then
Target = StrConv(Target, 3)
End If
End Sub

[doober]

Не прошло и 20 минут

IgorGO +1000
Игорь,у меня складывается впечатление.что у тебя есть волшебный хрустальный шар.Пора на кастинг в Битву...

[Kraimon]

вот что у меня получилось

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
On Error Resume Next ' Application.EnableEvents
Application.EnableEvents = False '
If Not Intersect(Target, Range("D1:F500")) Is Nothing Then
Target = StrConv(Target, 3)
End If
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
Target.EntireRow.Copy Sheets("выбыли").Rows(lr)
Target.EntireRow.Delete
End If
Application.EnableEvents = True '
End Sub

но работает не так как надо (

[kuklp]

На коленке, не проверяя:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
On Error Resume Next ' Application.EnableEvents
Application.EnableEvents = False '
If Not Intersect(Target, Range("D1:F500")) Is Nothing Then
Target = StrConv(Target, 3)
Application.EnableEvents = true 'эсли этого не сделать Экс перестанет отслеживать события
Exit Sub ' если первое условие выполнено, незачем проверять второе
End If
'If Target.Count > 1 Then Exit Sub уже проверяли, больше незачем
    Dim lr&
    lr = Sheets("выбыли").Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1 ' эти строки куда подевались?
If Not Intersect(Target, [a:a]) Is Nothing And Target.Value = "\" Then
Target.EntireRow.Copy Sheets("выбыли").Rows(lr)
Target.EntireRow.Delete
End If
Application.EnableEvents = True '
End Sub