Move row from one sheet to another automatically

[Berville141]

Hi
I have a work excel where I need to move a row from one sheet to another once that row has been marked completed.

The first sheet is called WIP and second is called COMPLETED.

The column which is marked as Completed when the task is done is column L
And I would like the row to move to the COMPLETED sheet on row 2 and moving the row currently in there down and so on.

Is this something that can be done?

Appreciate your help!

 

[VBasic2008]

How is column L populated? Manually or by formula?

 

[Berville141]

How is column L populated? Manually or by formula?

Manually

 

[VBasic2008]

Backup Rows (Worksheet Change)

• The solution uses two codes, each for a different module. It is 'customary' to place them as suggested, but they can both be in the sheet module.
• Carefully adjust the values in the constants section; Source First Row (srcFirstRow) was not mentioned.
• The solution will do everything automatically. If you already have occurrences of COMPLETED in column L, just do an in-place manual copy-paste-values and the data will be transferred.
  

Copy the following code into the sheet (object) module of worksheet WIP (Work in progress?):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    ' Constants
    Const srcFirstRow As Long = 2
    Const tgtName As String = "COMPLETED"
    Const tgtFirstRow As Long = 2
    Const CriteriaColumnIndex As Variant = "L"
    Const Criteria As String = "COMPLETED"
    
    ' Define Criteria Column Range ('rng').
    Dim rng As Range
    Set rng = getColumnRange(Me, CriteriaColumnIndex, srcFirstRow)
    If rng Is Nothing Then Exit Sub ' Criteria Column is 'Empty'.
    
    ' Define Criteria Range ('rng').
    Set rng = Intersect(rng, Target)
    If rng Is Nothing Then Exit Sub ' No changes in Criteria Column Range.
    
    ' Define Transfer Rows ('TRows').
    Dim TRows As Range
    Dim cel As Range
    For Each cel In rng.Cells
        ' vbTextCompare will allow "COMPLETED" or "completed" ...
        If StrComp(cel.Value, Criteria, vbTextCompare) = 0 Then
            collectRows TRows, cel
        End If
    Next cel
    If TRows Is Nothing Then Exit Sub ' Found no cells containing Criteria.
    
    ' Define Target Worksheet ('tgt').
    Dim tgt As Worksheet
    Set tgt = Me.Parent.Worksheets(tgtName)
    
    ' Copy Transfer Rows from Source Worksheet to Target Worksheet (in one go).
    copyRowsToOtherSheet TRows, tgt, CriteriaColumnIndex, tgtFirstRow
    
    ' Delete Transfer Rows from Source Worksheet (in one go).
    TRows.Delete
    
End Sub

Copy the following into a standard module e.g. Module1.

Option Explicit

Sub collectRows(ByRef CollectedRows As Range, _
                AddRange As Range)
    If Not CollectedRows Is Nothing Then
        Set CollectedRows = Union(CollectedRows, AddRange.EntireRow)
    Else
        Set CollectedRows = AddRange.EntireRow
    End If
End Sub

Sub copyRowsToOtherSheet(RowsRange As Range, _
                         OtherSheet As Worksheet, _
                         Optional ByVal LastRowColumnIndex As Variant = 1, _
                         Optional ByVal FirstRowNumber As Long = 1)
    Dim rng As Range
    Set rng = OtherSheet.Columns(LastRowColumnIndex) _
                        .Find(What:="*", _
                              LookIn:=xlFormulas, _
                              SearchDirection:=xlPrevious)
    If rng Is Nothing Then
        Set rng = OtherSheet.Cells(FirstRowNumber, 1)
    Else
        If rng.Row < FirstRowNumber Then
            Set rng = OtherSheet.Cells(FirstRowNumber, 1)
        Else
            Set rng = OtherSheet.Cells(rng.Row, 1).Offset(1)
        End If
    End If
    RowsRange.Copy rng
End Sub

Function getColumnRange(Sheet As Worksheet, _
                        Optional ByVal ColumnIndex As Variant = 1, _
                        Optional ByVal FirstRowNumber As Long = 1) _
         As Range
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnIndex).Find(What:="*", _
                                         LookIn:=xlFormulas, _
                                         SearchDirection:=xlPrevious)
    If rng Is Nothing Then Exit Function ' Empty column.
    If rng.Row < FirstRowNumber Then Exit Function ' Above FirstRowNumber.
    Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRowNumber, ColumnIndex), _
                                     rng)
End Function

 

[Berville141]

This almost works perfect only that the moved cells move to the bottom of the completed sheet not the top and move the rows down

Is this possible?

 

[Berville141]

Other option is for it to auto sort largest to smallest on colum A on COMPLETED sheet.
Not sure if that's another option

 

[VBasic2008]

Modified it. Should do the job now.

Sheet module

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    ' Constants
    Const srcFirstRow As Long = 2
    Const tgtName As String = "COMPLETED"
    Const tgtFirstRow As Long = 2
    Const CriteriaColumnIndex As Variant = "L"
    Const Criteria As String = "COMPLETED"
    
    ' Define Criteria Column Range ('rng').
    Dim rng As Range
    Set rng = getColumnRange(Me, CriteriaColumnIndex, srcFirstRow)
    If rng Is Nothing Then Exit Sub ' Criteria Column is 'Empty'.
    
    ' Define Criteria Range ('rng').
    Set rng = Intersect(rng, Target)
    If rng Is Nothing Then Exit Sub ' No changes in Criteria Column Range.
    
    ' Define Transfer Rows ('TRows').
    Dim TRows As Range
    Dim cel As Range
    For Each cel In rng.Cells
        ' vbTextCompare will allow "COMPLETED" or "completed" ...
        If StrComp(cel.Value, Criteria, vbTextCompare) = 0 Then
            collectRows TRows, cel
        End If
    Next cel
    If TRows Is Nothing Then Exit Sub ' Found no cells containing Criteria.
    
    ' Define Target Worksheet ('tgt').
    Dim tgt As Worksheet
    Set tgt = Me.Parent.Worksheets(tgtName)
    
    ' Copy Transfer Rows from Source Worksheet to Target Worksheet (in one go).
    copyToRowOnOtherSheet TRows, tgt, tgtFirstRow
    
    ' Delete Transfer Rows from Source Worksheet (in one go).
    TRows.Delete
    
End Sub

Standard Module

Option Explicit

Sub collectRows(ByRef CollectedRows As Range, _
                AddRange As Range)
    If Not CollectedRows Is Nothing Then
        Set CollectedRows = Union(CollectedRows, AddRange.EntireRow)
    Else
        Set CollectedRows = AddRange.EntireRow
    End If
End Sub

Sub copyToRowOnOtherSheet(RowsRange As Range, _
                          OtherSheet As Worksheet, _
                          Optional ByVal RowNumber As Long = 1)
    Dim rng As Range
    Dim RowsCount As Long
    For Each rng In RowsRange.Areas
        RowsCount = RowsCount + rng.Rows.Count
    Next
    Set rng = OtherSheet.Rows(RowNumber)
    rng.Resize(RowsCount).Insert Shift:=xlShiftDown, _
                                 CopyOrigin:=xlFormatFromRightOrBelow
    RowsRange.Copy rng.Offset(-RowsCount)
End Sub

Function getColumnRange(Sheet As Worksheet, _
                        Optional ByVal ColumnIndex As Variant = 1, _
                        Optional ByVal FirstRowNumber As Long = 1) _
         As Range
    Dim rng As Range
    Set rng = Sheet.Columns(ColumnIndex).Find(What:="*", _
                                              LookIn:=xlFormulas, _
                                              SearchDirection:=xlPrevious)
    If rng Is Nothing Then Exit Function ' Empty column.
    If rng.Row < FirstRowNumber Then Exit Function ' Above FirstRowNumber.
    Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRowNumber, ColumnIndex), _
                                     rng)

End Function

 

[Berville141]

Thats perfect thank you very much!

 

[punknwilly]

Modified it. Should do the job now.

Sheet module

So I am using this exact script that you provided the OP for something similar, but I want to step it up a notch. So I have a completed tab as well and that part of the script works flawlessly. Here is where I run into an error. I also want to have a column that once a certain drop-down is selected, in this case, "Video Studio" is selected that row is duplicated on a new tab labeled Video. Here is how I tried to attempt that.

Private Sub Worksheet_Change(ByVal Target As Range)
    Macro1 Target   'event runs when cell in Column B is changed
    Macro2 Target   'event runs when cell in Column L is changed
End Sub

Private Sub Macro1(ByVal Target As Range)

    ' Constants
    Const srcFirstRow As Long = 2
    Const tgtName As String = "COMPLETED"
    Const tgtFirstRow As Long = 2
    Const CriteriaColumnIndex As Variant = "B"
    Const Criteria As String = "COMPLETED"
   
    ' Define Criteria Column Range ('rng').
    Dim rng As Range
    Set rng = getColumnRange(Me, CriteriaColumnIndex, srcFirstRow)
    If rng Is Nothing Then Exit Sub ' Criteria Column is 'Empty'.
   
    ' Define Criteria Range ('rng').
    Set rng = Intersect(rng, Target)
    If rng Is Nothing Then Exit Sub ' No changes in Criteria Column Range.
   
    ' Define Transfer Rows ('TRows').
    Dim TRows As Range
    Dim cel As Range
    For Each cel In rng.Cells
        ' vbTextCompare will allow "COMPLETED" or "completed" ...
        If StrComp(cel.Value, Criteria, vbTextCompare) = 0 Then
            collectRows TRows, cel
        End If
    Next cel
    If TRows Is Nothing Then Exit Sub ' Found no cells containing Criteria.
   
    ' Define Target Worksheet ('tgt').
    Dim tgt As Worksheet
    Set tgt = Me.Parent.Worksheets(tgtName)
   
    ' Copy Transfer Rows from Source Worksheet to Target Worksheet (in one go).
    copyToRowOnOtherSheet TRows, tgt, tgtFirstRow
   
    ' Delete Transfer Rows from Source Worksheet (in one go).
    TRows.Delete
   
End Sub

Private Sub Macro2(ByVal Target As Range)

    ' Constants
    Const srcFirstRow As Long = 2
    Const tgtName As String = "VIDEO"
    Const tgtFirstRow As Long = 2
    Const CriteriaColumnIndex As Variant = "L"
    Const Criteria As String = "VIDEO STUDIO"
   
    ' Define Criteria Column Range ('rng').
    Dim rng As Range
    Set rng = getColumnRange(Me, CriteriaColumnIndex, srcFirstRow)
    If rng Is Nothing Then Exit Sub ' Criteria Column is 'Empty'.
   
    ' Define Criteria Range ('rng').
    Set rng = Intersect(rng, Target)
    If rng Is Nothing Then Exit Sub ' No changes in Criteria Column Range.
   
    ' Define Transfer Rows ('TRows').
    Dim TRows As Range
    Dim cel As Range
    For Each cel In rng.Cells
        ' vbTextCompare will allow "VIDEO STUDIO" or "video studio" ...
        If StrComp(cel.Value, Criteria, vbTextCompare) = 0 Then
            collectRows TRows, cel
        End If
    Next cel
    If TRows Is Nothing Then Exit Sub ' Found no cells containing Criteria.
   
    ' Define Target Worksheet ('tgt').
    Dim tgt As Worksheet
    Set tgt = Me.Parent.Worksheets(tgtName)
   
    ' Copy Transfer Rows from Source Worksheet to Target Worksheet (in one go).
    copyToRowOnOtherSheet TRows, tgt, tgtFirstRow
   
End Sub

Now everything works correctly so when I have a row that is in Video Studio it copies just fine to the other tab, but when that tab is eventually marked completed, it still does what it's suppose to do but also throws this error.

Run-time error '1004':
Method 'Intersect' of object'_Global' failed

When I debug it, it highlights the line I have marked in BOLD in the code above. Any help in fixing this would be great. Thank you.

 

[punknwilly]

So it didn't bold it but you can see where it was supposed to be bolded on under Define Criteria Range ('rng') in the Private Sub Macro2 section.