Search code examples
excelvbaexcel-formulaexcel-2010

The best way to achieve the requirement column in Excel


What is the best way to achieve the requirement from the sample data as per the screenshot attached? I want to merge the RED highlighted font in one row & delete the additional Row. Example - Data in row 4, 6 & 8 can move to the previous column & then 4, 6 & 8 rows should be completely deleted.

Note: there is no consistency in data the inconsistency of data may very between ROWS like B4, C6 & A8.

enter image description here


Solution

  • Delete Entire Rows With Condition

    • Loops through the rows from the bottom to the top.
    • If there is at least one blank cell, returns the value of each cell adjacent to the top of each non-blank cell, concatenated with the value of the non-blank cell, in the adjacent cell. Then it combines the first cell of the row into a range.
    • Deletes the entire rows of the combined range.
    Option Explicit
    
    Sub ConcatMissing()
        
        Const SecondDataRowFirstCellAddress As String = "A4"
        Const Delimiter As String = ""
        
        Dim ws As Worksheet: Set ws = ActiveSheet
        
        Dim fCell As Range: Set fCell = ws.Range(SecondDataRowFirstCellAddress)
        Dim rg As Range
        With fCell.CurrentRegion
            Set rg = fCell.Resize(.Row + .Rows.Count _
                - fCell.Row, .Column + .Columns.Count - fCell.Column)
        End With
        
        Dim cCount As Long: cCount = rg.Columns.Count
        
        Dim rrg As Range
        Dim rCell As Range
        Dim drg As Range
        Dim SkipRow As Boolean
        
        Dim r As Long
        For r = rg.Rows.Count To 1 Step -1
            Set rrg = rg.Rows(r)
            If Application.CountBlank(rrg) > 0 Then
                For Each rCell In rrg.Cells
                    If Len(CStr(rCell.Value)) > 0 Then
                        rCell.Offset(-1).Value = CStr(rCell.Offset(-1).Value) _
                            & Delimiter & CStr(rCell.Value)
                    End If
                Next rCell
                If drg Is Nothing Then
                    Set drg = rrg.Cells(1)
                Else
                    Set drg = Union(drg, rrg.Cells(1))
                End If
            End If
        Next r
        
        If drg Is Nothing Then Exit Sub
        
        drg.EntireRow.Delete
        
    End Sub