title: VBA macro to group all rows under one heading, headings when more than one heading exists
body: <p>I am writing a vba macro to achieve the following but do not how to implement it. Would any please provide some guidance?</p>
  
  <p>Currently, the data is as follows(subitem spans from column B onwards):</p>
  
  <pre><code>ITEM ONE [Subitem one... ]
  ITEM ONE [Subitem two ...]
  ITEM ONE [Subitem three...]  
  ITEM TWO [Subitem one  ...]
  ITEM THREE [Subitem one...]
  ITEM Three [Subitem two...] 
  </code></pre>
  
  <p>The following is what the data should look like in a separate sheet:</p>
  
  <pre><code>ITEM ONE  
  -------- 
  Subitem one  
  Subitem two 
  Subitem three  
  
  ITEM TWO 
  -------- 
  Subitem one  
  
  ITEM THREE 
  ---------- 
  Subitem one 
  Subitem two 
  </code></pre>
  
  <p>Any guidance/help will be greatly appreciated.</p>
  
  <p>Edited: solution as follows:</p>
  
  <pre><code>  r = Range("a65536").End(xlUp).Row
    c = Range("IU1").End(xlToLeft).Column
    a = Split(Cells(, c).Address, "$")(1)
    MsgBox "last row with data is " &amp; r &amp; " and last column with data is " &amp; a &amp; "", vbOKOnly, "LastRow and LastCol"
    rr = r + 1
  
    Application.Visible = False
  
    Range("A1:" &amp; a &amp; r &amp; "").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:= _
      xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
      DataOption1:=xlSortNormal
  
  Sheets("owssvr(1)").Select
  Sheets.Add
  
  
  'by default select first record and paste in reports sheet
  Sheets("owssvr(1)").Select
  Range("b2").Select
  Selection.Copy
  
  Sheets(1).Select
  Range("b2").Select
  ActiveSheet.Paste
  
     'paste header below it
  
  Sheets("owssvr(1)").Select
  Range("c1:" &amp; a &amp; "2").Select
  Selection.Copy
  
  Sheets(1).Select
  Range("b3").Select
  ActiveSheet.Paste
  
  
  
  For i = 3 To r
  Sheets(2).Select
  'Program name is same as above, dont copy name but row starting from next col, switch to other sheet, find last row in col B, add one to last row and paste
      If Cells(i, 2).Value = Cells(i - 1, 2) Then
          Range("C" &amp; i &amp; ":" &amp; a &amp; i &amp; "").Select
          Selection.Copy
  
          Sheets(1).Select
          'Range("b3").Select
          lr2 = Range("b65536").End(xlUp).Row
          Range("B" &amp; lr2 + 1 &amp; "").Select
          ActiveSheet.Paste
          Else
          'if name is not same as above, copy name, find last row, add two to add a gap from prev program name, paste program name, move to next row and paste remaining cols
           Sheets(2).Select
           Range("B" &amp; i &amp; "").Select
           Selection.Copy
  
           Sheets(1).Select
           lr2 = Range("b65536").End(xlUp).Row
           Range("B" &amp; lr2 + 2 &amp; "").Select
           ActiveSheet.Paste
  
           'copy headers
           Sheets(2).Select
  
           Range("c1:" &amp; a &amp; "1").Select
           Selection.Copy
           Sheets(1).Select
           lr2 = Range("b65536").End(xlUp).Row
           Range("B" &amp; lr2 + 1 &amp; "").Select
           ActiveSheet.Paste
  
           'copy cells(row, col+1)
           Sheets(2).Select
           Range("C" &amp; i &amp; ":" &amp; a &amp; i &amp; "").Select
           Selection.Copy
  
           Sheets(1).Select
          'Range("b3").Select
           lr2 = Range("b65536").End(xlUp).Row
           Range("B" &amp; lr2 + 1 &amp; "").Select
           ActiveSheet.Paste
  
      End If
      Next
  </code></pre>