Excel VBA to insert columns and split cell contents

I have an Excel sheet which contains following content:

I have worked on VBA code which does following:-

1. Find the column having Header ABC
2. Insert two new columns adjacent to ABC with name of AAA and BBB
3. Then split the ABC cell content into respective cells of AAA and BBB; note (ABC column may have one one line in some cases )
4. Follow step (3) till end of column ABC content.

End result should look like this:

I have written following code :-

Sub Num()
Dim rngDHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row; adjust as needed.
Set rngDHeader = rngHeaders.Find("ABC")

Sub sbInsertingColumns()
'Inserting a Column at Column B
rngDHeader.EntireColumn.Insert
'Inserting 2 Columns from C
rngDHeader.EntireColumn.Insert
 Dim rngDHeader As Range
   Dim sText As String
   Dim aText As Variant 'array
   Dim i As Long        'number of array elements

   Set rngDHeader = Sheets("Sheet1").Range("C2")

   Do Until rng = ""

      'split the text on carriage return character chr(10)
      aText = Split(rngDHeader.Value, Chr(10))

      'get the number of array elements
      i = UBound(aText)

      'build the output text string
      sText = aText(i - 2) & Chr(10) _
              & aText(i - 1) & Chr(10) _
              & aText(i)

      'output
      rngDHeader.Offset(, 1) = sText

      Set rngDHeader = rngDHeader.Offset(1, 0)
   Loop

   Set rngDHeader = Nothing

End Sub

Can anyone help me with this?

Dim colNum as Integer
colNum = ActiveSheet.Rows(1).Find(what:="ABC", lookat:=xlWhole).Column

' Done twice to insert 2 new cols
ActiveSheet.Columns(colNum + 1).Insert    
ActiveSheet.Columns(colNum + 1).Insert

' New col headings
ActiveSheet.Cells(1, colNum + 1).Value = "AAA"
ActiveSheet.Cells(1, colNum + 2).Value = "BBB"

' Define the range to iterate over as the used range of the found column
Dim colRange as Range 
With ActiveSheet
    Set colRange = .Range(.Cells(2, colNum), .Cells(.UsedRange.Rows.Count, colNum))
End With

Dim splitStr() as String

Dim vcell as Range
For Each vcell in colRange

    ' Create an array by splitting on the line break
    splitStr = Split(vcell.value, Chr(10))    

    ' Assign first new column as first array value.
    ActiveSheet.Cells(vcell.row, colNum + 1).Value = splitStr(0)

    ' Assign second new column as second array value. 
    ' First test if there *is* a second array value
    If UBound(splitStr) > 0 Then
        ActiveSheet.Cells(vcell.row, colNum + 2).Value = splitStr(1)        
    End If  

Next vcell

Tags: excelexcel, vba