Работает для верхнего блока (А2:К5), удалять по одной [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("A2:K5")) Is Nothing Then Exit Sub If Target.Value = "" Then Application.EnableEvents = False r = Target.Row If Target.Column < 11 Then Range(Target, Cells(r, 10)).Value = Range(Cells(r, Target.Column + 1), Cells(r, 11)).Value End If Cells(r, 11) = Cells(r + 1, 1) If r < 5 Then For r = r + 1 To 5 Range(Cells(r, 1), Cells(r, 10)).Value = Range(Cells(r, 2), Cells(r, 11)).Value Cells(r, 11) = Cells(r + 1, 1) Next End If Application.EnableEvents = True End If End Sub
[/vba]
Работает для верхнего блока (А2:К5), удалять по одной [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Intersect(Target, Range("A2:K5")) Is Nothing Then Exit Sub If Target.Value = "" Then Application.EnableEvents = False r = Target.Row If Target.Column < 11 Then Range(Target, Cells(r, 10)).Value = Range(Cells(r, Target.Column + 1), Cells(r, 11)).Value End If Cells(r, 11) = Cells(r + 1, 1) If r < 5 Then For r = r + 1 To 5 Range(Cells(r, 1), Cells(r, 10)).Value = Range(Cells(r, 2), Cells(r, 11)).Value Cells(r, 11) = Cells(r + 1, 1) Next End If Application.EnableEvents = True End If End Sub
Для любого блока с шапкой. Стирать можно сразу несколько (даже несвязанных) ячеек [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Range With Target.CurrentRegion rn_ = .Rows.Count If rn_ > 1 Then If Target(1) = "" Then If Intersect(Target, .Rows(1)) Is Nothing Then Set d = .Offset(1).Resize(rn_ - 1) n_ = WorksheetFunction.CountA(d) Application.ScreenUpdating = 0 Application.EnableEvents = 0 For i = 1 To d.Cells.Count If d(i) <> "" Then j = j + 1 If d(j) <> d(i) Then d(j) = d(i) d(i).ClearContents End If End If Next i Application.EnableEvents = 1 Application.ScreenUpdating = 1 End If End If End If End With End Sub
[/vba]
* Добавлено Немного переписал и файл перевложил
Для любого блока с шапкой. Стирать можно сразу несколько (даже несвязанных) ячеек [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Range With Target.CurrentRegion rn_ = .Rows.Count If rn_ > 1 Then If Target(1) = "" Then If Intersect(Target, .Rows(1)) Is Nothing Then Set d = .Offset(1).Resize(rn_ - 1) n_ = WorksheetFunction.CountA(d) Application.ScreenUpdating = 0 Application.EnableEvents = 0 For i = 1 To d.Cells.Count If d(i) <> "" Then j = j + 1 If d(j) <> d(i) Then d(j) = d(i) d(i).ClearContents End If End If Next i Application.EnableEvents = 1 Application.ScreenUpdating = 1 End If End If End If End With End Sub
[/vba]
* Добавлено Немного переписал и файл перевложил_Boroda_