excelvba

Shift the range up after clear contents


I have two tables in this sheet hence I'm unable to delete row.

How can I shift the row up from Column A to E if it's empty?

Sub Test()
    Dim ws          As Worksheet
    Dim e           As Variant
    Dim lr          As Long
    Dim r           As Long

    Set ws = ThisWorkbook.Sheets("Current")
    
    With Sheets("Archive")
        For r = 1 To ws.Cells(Rows.Count, 2).End(xlUp).Row
            If ws.Cells(r, 4) = "Done" Then
                lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                For Each e In Array("A", "B", "C", "D", "E")
                    .Range(e & lr) = ws.Range(e & r)
                    ws.Range(e & r).ClearContents
                Next e
            End If
        Next r
    End With
    Range("A:E").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    
End Sub

Solution

  • Copy Matching Rows (Archive Data)

    Before

    Screenshot Before

    After

    enter image description here

    Sub ArchiveData()
        Const PROC_TITLE As String = "Archive Data"
        Dim Msg As String
        On Error GoTo ClearError ' out-comment if error message to troubleshoot!
        
    Msg = "Defining constants"
        
        ' Source
        Const SRC_SHEET_NAME As String = "Current"
        Const SRC_COLUMNS As String = "A:E"
        Const SRC_FIRST_ROW As Long = 2
        Const SRC_SEARCH_COLUMN As Long = 4 ' n-th column of 'SRC_COLUMNS'!
        Const SRC_SEARCH_STRING As String = "Done"
        ' Destination
        Const DST_SHEET_NAME As String = "Archive"
        Const DST_FIRST_CELL_ADDRESS As String = "A2"
        ' Other
        Const MATCH_CASE As Boolean = False
        Const DO_NOT_DELETE_ROWS As Boolean = True ' reset when finished testing!
        Const SHOW_MESSAGES As Boolean = True
        
    Msg = "Referencing the workbook"
        
        Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
        
    Msg = "Retrieving source information"
        
        Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
        If sws.FilterMode Then sws.ShowAllData
        
        Dim srg As Range, sfrg As Range, slcell As Range, sRowsCount As Long
        
        With sws.Rows(SRC_FIRST_ROW).Columns(SRC_COLUMNS) ' first row
            Set sfrg = .Resize(sws.Rows.Count - .Row + 1) ' find range
            Set slcell = sfrg.Find(What:="*", LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            If slcell Is Nothing Then ' last non-empty cell by rows
                If SHOW_MESSAGES Then
                    MsgBox "No data found in ""'" & sws.Name & "'!" _
                        & sfrg.Address(0, 0) & """!", vbExclamation
                    Exit Sub
                End If
            End If
            sRowsCount = slcell.Row - .Row + 1
            Set srg = .Resize(sRowsCount)
        End With
        
        Dim scrg As Range: Set scrg = srg.Columns(SRC_SEARCH_COLUMN) ' search range
        
        Dim scData() As Variant:
        If sRowsCount = 1 Then
            ReDim scData(1 To 1, 1 To 1)
            scData(1, 1) = scrg.Value
        Else
            scData = scrg.Value
        End If
        
        Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
        
        If ColumnsCount < SRC_SEARCH_COLUMN Then
            MsgBox "The source range ""'" & sws.Name & "'!" _
                & srg.Address(0, 0) & """ has fewer than " & SRC_SEARCH_COLUMN _
                & " columns!", vbExclamation, PROC_TITLE
            Exit Sub
        End If
        
    Msg = "Combining matching rows into unioned range"
        
        Dim CompareMethod As Long: CompareMethod = MATCH_CASE + 1
        
        Dim surg As Range, srrg As Range, sValue As Variant
        Dim sRow As Long, dRowsCount As Long, WasSearchStringFound As Boolean
        
        For sRow = 1 To sRowsCount
            sValue = scData(sRow, 1)
            If Not IsError(sValue) Then
                If StrComp(sValue, SRC_SEARCH_STRING, CompareMethod) = 0 Then
                    dRowsCount = dRowsCount + 1
                    Set srrg = srg.Rows(sRow)
                    If WasSearchStringFound Then
                        Set surg = Union(surg, srrg)
                    Else
                        Set surg = srrg
                        WasSearchStringFound = True
                    End If
                End If
             End If
        Next sRow
            
        If Not WasSearchStringFound Then
            If SHOW_MESSAGES Then
                MsgBox "No rows with """ & SRC_SEARCH_STRING & """ in ""'" _
                    & sws.Name & "'!" & scrg.Address(0, 0) & """ found!", _
                    vbExclamation, PROC_TITLE
            End If
            Exit Sub
        End If
                
    Msg = "Retrieving destination information"
        
        Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
        If dws.FilterMode Then dws.ShowAllData
        
        Dim drg As Range, dfrg As Range, dlcell As Range, dRowOffset As Long
        
        With dws.Range(DST_FIRST_CELL_ADDRESS).Resize(, ColumnsCount) ' first row
            Set dfrg = .Resize(dws.Rows.Count - .Row + 1) ' find range
            Set dlcell = dfrg.Find(What:="*", LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
            If Not dlcell Is Nothing Then  ' last non-empty cell by rows
                dRowOffset = dlcell.Row - .Row + 1
            End If
            Set drg = .Offset(dRowOffset).Resize(dRowsCount)
        End With
        
    Msg = "Archiving rows"
                
        surg.Copy Destination:=drg
        Dim sAddress As String: sAddress = srg.Address(0, 0)
        Dim scAddress As String: scAddress = scrg.Address(0, 0)
        If Not DO_NOT_DELETE_ROWS Then surg.Delete Shift:=xlShiftUp
        
    Msg = "Informing"
            
        If SHOW_MESSAGES Then
            MsgBox dRowsCount & " row" & IIf(dRowsCount = 1, "", "s") & " of ""'" _
                & sws.Name & "'!" & sAddress & """ with """ _
                & SRC_SEARCH_STRING & """ in """ & scAddress & " " _
                & IIf(DO_NOT_DELETE_ROWS, "copie", "move") & "d to ""'" _
                & dws.Name & "'!" & drg.Address(0, 0) & """.", _
                vbInformation, PROC_TITLE
        End If
        
    ProcExit:
        Exit Sub
    ClearError: ' e.g. not enough rows in the destination sheet
        MsgBox "Run-time error [" & Err.Number & "]: (while " & LCase(Msg) & ")" _
            & vbLf & vbLf & Err.Description, vbCritical, PROC_TITLE
        Resume ProcExit
    End Sub