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
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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.