Move Rows from one table to another based on whether a column contains text

Question

I have a task list table in Excel. I'm trying to create a VBA macro for sorting the assigned tasks automatically. When the macro is run I want it to check whether each row contains a name in the 'assigned' column and if it does, move the row to another table.

I have some code from another post that almost works (VBA Move rows from one table to another based on condition), except that it doesn't check whether the 'assigned' column is filled out correctly.

The code above only checks whether the column has been filled out with 2 specific values, but my column can be filled with up to 60 values. So I tried to amend the code so that it just checked whether the cell contained any text using IsEmpty(False), but this hasn't worked. The code runs, but it just moves all the rows which are empty in the 'Assigned' column, but I want it to move the cells that aren't empty.

My code currently looks like this:

' Move assigned NewTasks  to the AssignedTasks list '
   Sub MoveClosed()
  
        Dim wb As Workbook, loOpen As ListObject, loClosed As ListObject
        Dim lr As ListRow, i As Long
        
        Set wb = ActiveWorkbook
        Set loOpen = wb.Worksheets("NewTasks").ListObjects("Table1")
        Set loClosed = wb.Worksheets("AssignedTasks").ListObjects("Table3")
        
        For i = loOpen.ListRows.Count To 1 Step -1
            Set lr = loOpen.ListRows(i)
            Select Case lr.Range.Cells(14).Value
                Case IsEmpty(False)
                    lr.Range.Copy loClosed.ListRows.Add.Range.Cells(1)
                    lr.Delete
            End Select
        Next i
    
    End Sub

Thanks for your help!

Answer 1

Copy Excel Table Rows Using AutoFilter

• Just an alternative since looping could take forever on a large dataset.

Sub MoveClosedTasks()
    
    ' Tables
    Dim slo As ListObject, dlo As ListObject
    With ActiveWorkbook
        Set slo = .Worksheets("NewTasks").ListObjects("Table1")
        Set dlo = .Worksheets("AssignedTasks").ListObjects("Table3")
    End With
    
    Application.ScreenUpdating = False
    
    ' Source
    Dim srg As Range
    With slo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
        .Range.AutoFilter 14, "<>"
        On Error Resume Next
            Set srg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        .AutoFilter.ShowAllData
    End With
    If srg Is Nothing Then
        MsgBox "No closed tasks found!", vbExclamation
        Exit Sub
    End If
    
    ' Destination
    Dim drg As Range, ShowingTotals As Boolean
    With dlo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
        If .ShowTotals Then
            .ShowTotals = False
            ShowingTotals = True
        End If
        Set drg = .HeaderRowRange.Offset(.ListRows.Count + 1)
    End With
    
    ' Move.
    srg.Copy drg
    srg.Delete xlShiftUp
    If ShowingTotals Then dlo.ShowTotals = True
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Closed tasks moved.", vbInformation

End Sub