Move data from one sheet to another based on value

[JJabra]

Hi Guys,

I want a code that moves a whole row from one tab to another when there is the word done in row L. This would run on the press of a button.

I have the below code, just not sure exactly how to adapt it to delete the row

Sub CopyDone()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    
    Set Source = ActiveWorkbook.Worksheets("Main Tab")
    Set Target = ActiveWorkbook.Worksheets("Done")

    j = 2
    For Each c In Source.Range("L2:L1000")
        If c = "Done" Then
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
End Sub

Any help would be greatly appreciated. Thanks in advance!

 

[JJabra]

Which line of code gave the error?

I comes up on the first line ".Range("L1:L1000")

 

[JJabra]

where did it fail on my solution?

Dave

it seems to get stuck into a loop when it gets to

For Each Cell In Source.Range("L2:L1000")
If UCase(Cell) = "DONE" Then
If CopyRange Is Nothing Then
Set CopyRange = Cell
Else
Set CopyRange = Union(CopyRange, Cell)
End If
End If
Next Cell

on the debug it goes back up to the first line

 

[dmt32]

it seems to get stuck into a loop when it gets to

For Each Cell In Source.Range("L2:L1000")
If UCase(Cell) = "DONE" Then
If CopyRange Is Nothing Then
Set CopyRange = Cell
Else
Set CopyRange = Union(CopyRange, Cell)
End If
End If
Next Cell

on the debug it goes back up to the first line

tad strange as runs ok for me
made couple subtle changes - see if any help

Sub CopyDone()
    Dim Cell As Range, CopyRange As Range
    Dim Target As Range
    Dim wsSource As Worksheet
   
    Set wsSource = ThisWorkbook.Worksheets("Main Tab")
    Set Target = ThisWorkbook.Worksheets("Done").Range("A2")
   
    For Each Cell In wsSource.Range("L2:L1000")
        If UCase(Cell.Value) = "DONE" Then
            If CopyRange Is Nothing Then
                Set CopyRange = Cell
            Else
                Set CopyRange = Union(CopyRange, Cell)
            End If
        End If
    Next Cell
   
    If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
        .Copy Target
        .Delete shift:=xlShiftUp
    End With
    End If
End Sub

 

[Fluff]

Is your data in a structured table?

 

[JJabra]

I think I worked out the issue, the table that was given to me to look at consisted of a couple of tables, Now that I have organised it into one table the macro works.

However I was wondering, is there a way to make the data copy not necessarily to the top row of another sheet but instead to the next empty row?

Also can it copy only the value?

 

[dmt32]

However I was wondering, is there a way to make the data copy not necessarily to the top row of another sheet but instead to the next empty row?

Also can it copy only the value?

Hi,
try this update

Sub CopyDone()
    Dim Cell As Range, CopyRange As Range
    Dim Target As Range
    Dim Source As Worksheet
    
    Set Source = ThisWorkbook.Worksheets("Main Tab")
   
     With ThisWorkbook.Worksheets("Done")
       Set Target = .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1)
     End With
    
    For Each Cell In Source.Range("L2:L1000")
        If UCase(Cell.Value) = "DONE" Then
            If CopyRange Is Nothing Then
                Set CopyRange = Cell
            Else
                Set CopyRange = Union(CopyRange, Cell)
            End If
        End If
    Next Cell
    
    If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
        .Copy
        Target.PasteSpecial xlPasteValues
        .Delete shift:=xlShiftUp
    End With
    End If
    Application.CutCopyMode = False
End Sub

Dave

 

[JJabra]

Hi Dave, Thanks for your response, this is almost perfect, just unfortunately the data copies underneath the table on the second tab rather than into the next free line in the table.

 

[dmt32]

Hi Dave, Thanks for your response, this is almost perfect, just unfortunately the data copies underneath the table on the second tab rather than into the next free line in the table.

if your data is structured as a Table- then locating last low may need a different approach

not tested but see if this change resolves

Sub CopyDone()
    Dim Cell As Range, CopyRange As Range
    Dim Target As Range
    Dim Source As Worksheet
   
    Set Source = ThisWorkbook.Worksheets("Main Tab")
  
     With ThisWorkbook.Worksheets("Done")
        Set Target = .Cells(NewRow(.Name), 1)
     End With
   
    For Each Cell In Source.Range("L2:L1000")
        If UCase(Cell.Value) = "DONE" Then
            If CopyRange Is Nothing Then
                Set CopyRange = Cell
            Else
                Set CopyRange = Union(CopyRange, Cell)
            End If
        End If
    Next Cell
   
    If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
        .Copy
        Target.PasteSpecial xlPasteValues
        .Delete shift:=xlShiftUp
    End With
    End If
    Application.CutCopyMode = False
End Sub

Function NewRow(ByVal sh As String) As Long
    On Error Resume Next
    NewRow = Worksheets(sh).Cells.Find(What:="*", After:=Worksheets(sh).Range("A1"), _
                                        Lookat:=xlPart, LookIn:=xlFormulas, _
                                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                                        MatchCase:=False).Row + 1
    On Error GoTo 0
End Function

Dave

 

[JJabra]

Hi Dave, this still seems to be Putting the data underneath the table. Any other ideas on how to get it to populate the table?

 

[dmt32]

Hi Dave, this still seems to be Putting the data underneath the table. Any other ideas on how to get it to populate the table?

Sorry not much time at moment but try these changes

replace this section

If Not CopyRange Is Nothing Then
        With CopyRange.EntireRow
        .Copy
        Target.PasteSpecial xlPasteValues
        .Delete shift:=xlShiftUp
    End With
    End If

with this

If Not CopyRange Is Nothing Then
        Target.ListObject.ListRows.Add AlwaysInsert:=True
        With CopyRange.EntireRow
        .Copy
        Target.Offset(1).PasteSpecial xlPasteValues
        .Delete shift:=xlShiftUp
    End With
    End If

In the Function code delete the "+1"

MatchCase:=False).Row + 1

Dave