根据单元格值移动范围

Question

I'm quite new to VBA and am working on a code to copy a range only if a cell value in the same row is "Completed".

The copied range is then pasted in another column and the original range is deleted.

It would be great if it could loop as well so that the movement happens automatically when the cell value is changed to completed. My code so far is:

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

You need to use the built-in event Worksheet_Change :

In vbe , on the left, double-click on the sheet you want this code to work. You'll access the sheet module, you have 2 lists just upon the text editor to select which event you want to use.

You can use this code there, it'll transfer the data of the 'Completed' line from B:O to 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

I used offset to move the data across and an insert "Delete" function to delete the original range. The offset created an un-bordered cell which I had to fix and I also cleared the "Completed" cell once it had been moved to the new range.

I'm still struggling with the loop but I'll continue trying.

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