Home > Net >  I want to transfer a row to another sheet and delete it from the current one based on a YES/NO crite
I want to transfer a row to another sheet and delete it from the current one based on a YES/NO crite

Time:03-21

I want to transfer collumn with "No" criteria in CTA demisie sheet and delete it from the CTA one.

PHOTO_OF_TABLE

CodePudding user response:

I understand that you want to move all rows from the sheet named CTA that have the value "No" in column "F" to the sheet named CTA-Demise. That is what the following code does. You just need to open the VBA code editor, insert a new module and paste this code there. Then run the code.

Sub move_cta_no()
    Dim src As Worksheet
    Dim dest As Worksheet
    Dim r As Long
    Dim free_row As Long

    Set src = ThisWorkbook.Worksheets("CTA")
    Set dest = ThisWorkbook.Worksheets("CTA-Demise")
    free_row = dest.Cells(dest.Rows.Count, 1).End(xlUp).row
    
    
    For r = src.Cells(src.Rows.Count, "F").End(xlUp).row To 2 Step -1
        If src.Cells(r, "F").Value = "NO" Then
            'found a row that needs to be moved
                free_row = free_row   1
                src.Rows(r).Copy
                dest.Rows(free_row).Value = src.Rows(r).Value
                src.Rows(r).Delete
        End If
    Next

End Sub

CodePudding user response:

Move Data Using AutoFilter

Option Explicit

Sub MoveCTA()

    Application.ScreenUpdating = False

    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets("CTA")
    If sws.FilterMode Then sws.ShowAllData
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets("CTA demisie")
    Dim dCell As Range
    Set dCell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
    
    srg.AutoFilter srg.Columns.Count, "No"

    Dim svdrg As Range
    On Error Resume Next
        Set svdrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    sws.AutoFilterMode = False
    
    If Not svdrg Is Nothing Then
        svdrg.Copy dCell
        svdrg.Delete xlShiftUp
    End If
    
    Application.ScreenUpdating = True
    
    MsgBox "Data moved.", vbInformation
    
End Sub
  • Related