Копирование строк в разные листы книги по значению ячейки в столбце

[kaasin]

Здравствуйте,

Есть таблица, где в Лист1 ведется учет хранения одного вида продукции разными клиентами, нужно, чтобы при вводе в колонку "Контрагент" (D), вся строка (27 ячеек), не зависимо от того, все ли ячейки заполнены, переносилась на лист данного клиента в последнюю незаполненную строку.

То есть вводим id товара, место хранения, дату поступления, кем принят и т.д. (остаются свободны ячейки с датой выдачи, кому выдан и т.д), вводим наименование клиента (Клиент1) - строка перенеслась в Лист2 данного клиента на последнюю строку, вводим Клиент2 - строка переноситься в Лист3 на последнюю незаполненную строку.
В случае редактирования строки (внесения даты выдачи, кому выдан, удаления места хранения), изменения и вступают в силу на листе клиента.

Нашел только такое решение:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D:D")) Is Nothing Then
If Target = "Клиент1" Then
With Sheets("Лист2")
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.Count A(Range(Cells(Target.Row, 1), Cells(Target.Row, 27))) = 27 Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 27)).Copy
.Cells(LastRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
End If
End If

If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("D:D")) Is Nothing Then
If Target = "Клиент2" Then
With Sheets("Лист3")
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
If Application.WorksheetFunction.Count A(Range(Cells(Target.Row, 1), Cells(Target.Row, 27))) = 27 Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 27)).Copy
.Cells(LastRow + 1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
End If
End If
End Sub

Но добавляет по примеру:

Лист1, 1 строка Клиент1 - переносит в Лист2 в стоку 1
Лист1, 2 строка Клиент2 - переносит в Лист3 в стоку 2
То есть в Лист3 первая строка остается пустой.

Подскажите пожалуйста решение, без Вас никогда не справиться с этой задачей.

[Aleksandr H.]

1. отформатируй код согласно правил
2. приложи какие-то файлы с разработками

[IgorGO]

дайте листам такие же имена как у контрагентов
тогда
вместо того, что написано у Вас можно использовать этот

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim LastRow As Long
  If Target.Cells.Count > 1 Then Exit Sub
  If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
  On Error Resume Next
  If IsEmpty(Worksheets(Target).Cells(1)) Then LastRow = 1
  If Err Then Exit Sub
  With Worksheets(Target)
    Range(Cells(Target.Row, 1), Cells(Target.Row, 27)).Copy
    .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
  End With
End Sub