excelvba

How to insert one Row from duplicate row data and fill insert row VBA


im have Problem and i hope u can help me :)

I really confused about this problem, because i dont how i can do that, i search on google and i cant found anything

i just want to insert one row for every duplicate row data/ Table and fill that with something from each duplicate data, u can see image below

Table A --> Table B --> Table C

I Hope u help me With **VBA **

​Thankss ;)

enter image description here


Solution

    • By changing Range("E1") to Range("A1"), output table will overwrite the source table.
    Option Explicit
    
    Sub Demo()
        Dim i As Long, j As Long, k As Long
        Dim arrData, lastRow As Long
        Dim arrRes, RowCnt As Long, ColCnt As Long
        Dim rRow As Range, sRow As String, r, rCell as Range
        ' Load data
        lastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        arrData = ActiveSheet.Range("A1:C" & lastRow).Value
        RowCnt = UBound(arrData)
        ColCnt = UBound(arrData, 2)
        ReDim arrRes(1 To RowCnt * 2, 1 To ColCnt)
        k = 1
        ' Loop through data
        For i = LBound(arrData) To RowCnt - 1
            For j = 1 To ColCnt
                arrRes(k, j) = arrData(i, j)
            Next j
            k = k + 1
            ' Add JOB row
            If Not arrData(i, ColCnt) = arrData(i + 1, ColCnt) Then
                arrRes(k, 1) = "JOB " & arrData(i, ColCnt)
                sRow = sRow & "," & k
                k = k + 1
            End If
        Next i
        ' Write data to sheet
        Set rCell = Range("E1")
        rCell.Resize(1, ColCnt).EntireColumn.Clear
        rCell.Resize(k - 1, ColCnt).Value = arrRes
        ' Apply color to JOB row
        For Each r In Split(Mid(sRow, 2), ",")
            If rRow Is Nothing Then
                Set rRow = rCell.Offset(r - 1).Resize(1, ColCnt)
            Else
                Set rRow = Application.Union(rRow, rCell.Offset(r - 1).Resize(1, ColCnt))
            End If
        Next
        If Not rRow Is Nothing Then
            rRow.Interior.Color = vbYellow
        End If
    End Sub
    

    enter image description here