Move row from one sheet to another automatically

Berville141

New Member
Joined
Oct 1, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
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!
 

Some videos you may like

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

VBasic2008

Board Regular
Joined
Oct 25, 2016
Messages
88
Office Version
  1. 2019
Platform
  1. Windows
How is column L populated? Manually or by formula?
 

VBasic2008

Board Regular
Joined
Oct 25, 2016
Messages
88
Office Version
  1. 2019
Platform
  1. Windows
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?):

VBA Code:
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.

VBA Code:
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

New Member
Joined
Oct 1, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Oct 1, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
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

Board Regular
Joined
Oct 25, 2016
Messages
88
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Modified it. Should do the job now.

Sheet module

VBA Code:
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

VBA Code:
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
 

punknwilly

New Member
Joined
Oct 27, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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.

Rich (BB code):
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.
 
Last edited by a moderator:

punknwilly

New Member
Joined
Oct 27, 2020
Messages
4
Office Version
  1. 365
Platform
  1. Windows
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,123,206
Messages
5,600,313
Members
414,375
Latest member
Onmyown

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top