Excel macro to insert columns and split cell contents


I have an Excel sheet which contains following content:

enter image description here

I have worked on a macro 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:

enter image description here

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
'Inserting 2 Columns from C
 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)

      rngDHeader.Offset(, 1) = sText

      Set rngDHeader = rngDHeader.Offset(1, 0)

   Set rngDHeader = Nothing

End Sub

Can anyone help me with this?

Show source
| excel-vba   | vba   | excel   | macros   2017-01-05 12:01 1 Answers

Answers ( 1 )

  1. 2017-01-05 13:01

    Numbered as per your question:

    1.Find the Column having Header ABC

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

    2.Insert Two new Column Adjacent to ABC with Name of AAA and BBB

    ' 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"

    3.Then Split the ABC cell content into respective AAA and BBB; note (ABC column may have one one line in some cases )


    4.Follow the process till end of column ABC content.

    ' 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
◀ Go back