VB Code for Moving Row

Rob_010101

Board Regular
Joined
Jul 24, 2017
Messages
198
Office Version
  1. 365
Platform
  1. Windows
I am working with an absence tracker and am currently using the below VB Code so when a drop-down list item returns "Closed", it copies the row across to the "Archived Absence" sheet.

In the drop down, there is also a selection "LTS" for Long Term Sick people. When "LTS" is selected, I need it to copy the row over to the "Long Term" sheet.

In short:

- if "closed" is selected, it moves to "Archived absence"
- if "LTS" is selected, it moves to "Long Term"

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fromRow%, archiveRow%, archiveList As Worksheet

    If Target.Cells.Count > 1 Then Exit Sub
  
    If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
        Set archiveList = ThisWorkbook.Worksheets("Archived Absence")
            If Target.Value = "Closed" Then
                fromRow = ActiveCell.Row
                
                With archiveList
                    If .FilterMode Then
                        Dim strMatch As String
                        strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
                        archiveRow = Evaluate(strMatch) + 1
                    Else
                        archiveRow = archiveList.Cells(archiveList.Rows.Count, 1).End(3).Row + 1
                    End If
                End With
                
                Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy archiveList.Cells(archiveRow, 1)
                Rows(fromRow).EntireRow.Delete
            End If
    End If
End Sub

The above code has been designed to include when filters are applied, to make sure the moving does not overwrite anything.

My issue is getting the code to do both (I have no knowledge of VB and I got the above by asking on forums).

Regards
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Hi, Chris,

maybe try this option where I just used one variable for the target sheet and a Select Case for finding out whether to move or not. Please try this code on a copy first:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
 
  Dim fromRow%
  Dim archiveRow%
  Dim strMatch As String
  Dim wsTarget As Worksheet   'sheet to move data to
  Dim blnMove As Boolean      'whether to move data or not

  If Target.Cells.Count > 1 Then Exit Sub

  If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
    Select Case UCase(Target.Value)       'as you have given both "closed" and "Closed"
      Case "CLOSED"
        Set wsTarget = ThisWorkbook.Worksheets("Archived Absence")
        blnMove = True
      Case "LTS"
        Set wsTarget = ThisWorkbook.Worksheets("Long Term")
        blnMove = True
      Case Else
        blnMove = False
    End Select
    If blnMove Then
       'section of code is taken from your posting
      fromRow = ActiveCell.Row
      With wsTarget     'only change made here
        If .FilterMode Then
          strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
          archiveRow = Evaluate(strMatch) + 1
        Else
          archiveRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(3).Row + 1
        End If
      End With
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      Rows(fromRow).EntireRow.Delete
      Set wsTarget = Nothing    'added line
    End If
  End If

End Sub
Ciao,
Hiolger
 
Upvote 0
Hi, Chris,

maybe try this option where I just used one variable for the target sheet and a Select Case for finding out whether to move or not. Please try this code on a copy first:
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
 
  Dim fromRow%
  Dim archiveRow%
  Dim strMatch As String
  Dim wsTarget As Worksheet   'sheet to move data to
  Dim blnMove As Boolean      'whether to move data or not

  If Target.Cells.Count > 1 Then Exit Sub

  If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
    Select Case UCase(Target.Value)       'as you have given both "closed" and "Closed"
      Case "CLOSED"
        Set wsTarget = ThisWorkbook.Worksheets("Archived Absence")
        blnMove = True
      Case "LTS"
        Set wsTarget = ThisWorkbook.Worksheets("Long Term")
        blnMove = True
      Case Else
        blnMove = False
    End Select
    If blnMove Then
       'section of code is taken from your posting
      fromRow = ActiveCell.Row
      With wsTarget     'only change made here
        If .FilterMode Then
          strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
          archiveRow = Evaluate(strMatch) + 1
        Else
          archiveRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(3).Row + 1
        End If
      End With
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      Rows(fromRow).EntireRow.Delete
      Set wsTarget = Nothing    'added line
    End If
  End If

End Sub
Ciao,
Hiolger
Thank you!

There is something else. I have a sheet labelled "employee data" which is updated weekly, so that data in other sheets can be populated with ease using vlookups.

Is there a way to add something into the above so that when a row is moved over to "archived absence", paste values is applied to the row so that cells containing job title etc aren't updated in the archive when the employee data is refreshed. I would need to keep the formulas in the "Long Term" sheet, so just when it's moved to "Archived Absence".

I hope that makes sense and thank you again for your help with this.

Kindest Regards
 
Upvote 0
Hi Chris,

without knowing how your data looks like I would ask you to check if the addition of this one code line comes close to what you are looking for.

Please change
VBA Code:
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      Rows(fromRow).EntireRow.Delete
to
VBA Code:
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      wsTarget.Cells(archiveRow, 1).Resize(1, 15).Value = Cells(fromRow, 1).Resize(1, 15).Value
      Rows(fromRow).EntireRow.Delete

You will get all the formatting by using Copy and the new line will copy over only the values.

HTH, Holger
 
Upvote 0
Hi Chris,

without knowing how your data looks like I would ask you to check if the addition of this one code line comes close to what you are looking for.

Please change
VBA Code:
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      Rows(fromRow).EntireRow.Delete
to
VBA Code:
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      wsTarget.Cells(archiveRow, 1).Resize(1, 15).Value = Cells(fromRow, 1).Resize(1, 15).Value
      Rows(fromRow).EntireRow.Delete

You will get all the formatting by using Copy and the new line will copy over only the values.

HTH, Holger
Hello Hiolger,

This worked for the archive sheet but pasted values on the Long Term sheet too

Range(Cells(fromRow, 1), Cells(fromRow, 18)).Copy wsTarget.Cells(archiveRow, 1)
wsTarget.Cells(archiveRow, 1).Resize(1, 18).Value = Cells(fromRow, 1).Resize(1, 18).Value
Rows(fromRow).EntireRow.Delete

I changed "15" to "18" as it's 18 columns.

I'm struggling to get the downloadable add-in to work on my work laptop, probably because of security restrictions, so can't upload my template to this site. I could add some images into the comments if it helps?

Regards
 
Upvote 0
Hi Chris,

you could use another boolean for setting true for only pasting to the archives and add an If ... Then with that boolean just before. Code may look like this
VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
 
  Dim fromRow%
  Dim archiveRow%
  Dim strMatch As String
  Dim wsTarget As Worksheet   'sheet to move data to
  Dim blnMove As Boolean      'whether to move data or not
  Dim blnOnlyValues As Boolean   'determine if it´s the arvjice
  
  If Target.Cells.Count > 1 Then Exit Sub

  If Not Application.Intersect(Target, Range("O2:O500000")) Is Nothing Then 'amend this range address to your
    blnOnlyValues = False
    Select Case UCase(Target.Value)       'as you have given both "closed" and "Closed"
      Case "CLOSED"
        Set wsTarget = ThisWorkbook.Worksheets("Archived Absence")
        blnMove = True
        blnOnlyValues = True
      Case "LTS"
        Set wsTarget = ThisWorkbook.Worksheets("Long Term")
        blnMove = True
      Case Else
        blnMove = False
    End Select
    If blnMove Then
       'section of code is taken from your posting
      fromRow = ActiveCell.Row
      With wsTarget     'only change made here
        If .FilterMode Then
          strMatch = "match" & Replace("(2,1/(a:a>""""),1)", "a:a", .AutoFilter.Range.Cells(1).EntireColumn.Address(0, 0, 1, 1))
          archiveRow = Evaluate(strMatch) + 1
        Else
          archiveRow = wsTarget.Cells(wsTarget.Rows.Count, 1).End(3).Row + 1
        End If
      End With
      Range(Cells(fromRow, 1), Cells(fromRow, 15)).Copy wsTarget.Cells(archiveRow, 1)
      If blnOnlyValues Then wsTarget.Cells(archiveRow, 1).Resize(1, 15).Value = Cells(fromRow, 1).Resize(1, 15).Value
      Rows(fromRow).EntireRow.Delete
      Set wsTarget = Nothing    'added line
    End If
  End If

End Sub
Do you really need to take care of 500 000 rows? I would restrict the area to where data has been entered (values, not formulae) like
VBA Code:
If Not Application.Intersect(Target, Range("O2:O" & Range("A" & Rows.Count).End(xlUp).Row)) Is Nothing Then
assuming that data is entered by hand into Column A.

Please forgive me but the last post was the first to mention an add-in. And if the code you posted hasn´t any wrapper in the add-in t make it work on a sheet in a "normal" workbook it will only work in the add-in (which doesn´t show any sheets to trigger the events).

Ciao,
Holger
 
Upvote 0
Solution
Hello Holger,

Great success, your code above seems to work! :) I am very grateful for your help with this.

Kindest Regards
Chris
 
Upvote 0

Forum statistics

Threads
1,223,886
Messages
6,175,191
Members
452,616
Latest member
intern444

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
Back
Top