Перемещение диапазона на основе значения ячейки

Question

Я довольно новичок в VBA и работаю над кодом для копирования диапазона, только если значение ячейки в той же строке «Завершено».

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

Было бы здорово, если бы он мог зацикливаться, так что движение происходит автоматически, когда значение ячейки изменяется на завершенное. Мой код до сих пор:

Sub Move() 

    Dim r As Range, cell As Range, mynumber As Long 

    Set r = Range("O1:O1000") 

    mynumber = 1 
    For Each cell In r 
     If cell.Value = "Completed" Then 
     Range("Q15:AE15").Select 
     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 

     If cell.Value = "Completed" Then 
     ActiveCell.Select 
     ActiveCell.Range("B:O").Select 
     Selection.Copy 
     Range("Q14").Select 
     ActiveSheet.Paste 

     End If 

     Next 

    End Sub 

Answer 1

Вы должны использовать встроенный в событие Worksheet_Change:

В vbe, слева, дважды щелкните на листе, который вы хотите этот код работать. Вы получите доступ к модулю листа, у вас есть 2 списка только в текстовом редакторе, чтобы выбрать, какое событие вы хотите использовать.

Вы можете использовать этот код там, он будет передавать данные «Completed» линии от B: O в Q: AE:

Private Sub Worksheet_Change(ByVal Target As Range) 
If Target.Cells.Count > 1 Then Exit Sub 

If Not Application.Intersect(Me.Columns(15), Target) Is Nothing Then 
    If Target.Value <> "Completed" Then 
    Else 
     Dim FirstFreeRowInColQ As Long 
     FirstFreeRowInColQ = Me.Range("Q" & Me.Rows.Count).End(xlUp).Row + 1 

     Me.Range("Q" & FirstFreeRowInColQ & ":AE" & FirstFreeRowInColQ).Value = _ 
      Me.Range("B" & Target.Row & ":O" & Target.Row).Value 
    End If 
Else 
End If 

End Sub 

Answer 2

Я использовал смещение для перемещения данных через и вставку «Удалить», чтобы удалить исходный диапазон. Смещение создало неграничную ячейку, которую я должен был исправить, и я также очистил ячейку «Завершено», как только она была перенесена в новый диапазон.

Я все еще борюсь с петлей, но я продолжу попытки.

Sub Move() 

Dim r As Range, cell As Range, mynumber As Long 

Set r = Range("O1:O1000") 

mynumber = 1 
For Each cell In r 
    If cell.Value = "Completed" Then 
    Range("Q14:AE14").Select 
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 

    End If 

    If cell.Value = "Completed" Then 
    cell.Select 
    cell.Value = "Delete" 
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select 
    Selection.Copy 
    Range("Q14").Select 
    ActiveSheet.Paste 

     With Selection.Borders(xlEdgeLeft) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeTop) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeBottom) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 
With Selection.Borders(xlEdgeRight) 
    .LineStyle = xlContinuous 
    .ColorIndex = 0 
    .TintAndShade = 0 
    .Weight = xlThin 
End With 

    Range("AE14").ClearContents 

    End If 

    If cell.Value = "Delete" Then 
    cell.Select 
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select 
    Selection.Delete Shift:=xlUp 

    End If 

    Next 

End Sub