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]

Hi Dave, thank you for getting back to me,

Where I have made the changes detailed above, I am now getting the following error pop up;

Run-time error '91':

Object variable or With block variable not Set

Do you know whats causing this and how to fix it?

 

[dmt32]

I would hazard a guess that you have not deleted the +1 value in the function

Here are both codes with all updates

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
        Target.ListObject.ListRows.Add AlwaysInsert:=True
        With CopyRange.EntireRow
        .Copy
        Target.Offset(1).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
    On Error GoTo 0
End Function

untested but hopefully, will do what you want

Dave

 

[JJabra]

Hi Dave, I had removed the +1 and it does copy the data to the first available row as intended, the only issue seems to be there is an error in deleting the row on the main tab as the error pops up after the data is moved

 

[dmt32]

Hi Dave, I had removed the +1 and it does copy the data to the first available row as intended, the only issue seems to be there is an error in deleting the row on the main tab as the error pops up after the data is moved

whats the error?

Dave

 

[JJabra]

It seems to just be popping up saying '400'

 

[dmt32]

Just made dummy workbook & code seems to work ok for me

Does the code stop for you on this line

.Delete shift:=xlShiftUp

Dave

 

[JJabra]

It does appear so yes, also now coming up saying Delete method of range class failed. When Debugging it stops on the above mentioned line

 

[dmt32]

I take it sheet is not protected?

If still having issues can you place copy of of the workbook with sample data in a dropbox?

Dave