Excel Macro 2007 sorting, merging

Option Explicit
Sub CopyFormatSheet()
    Dim currs As Worksheet, rngSort As Range, rngSortKey As Range
    Dim oldcompany As String, i As Integer, rngsize As Integer
    ActiveSheet.Copy before:=Sheets(2)
    
    Set currs = ActiveSheet
    Set rngSort = currs.UsedRange
    
    '>1>> do the sort
    Set rngSortKey = rngSort.Columns(1)
    currs.Sort.SortFields.Clear
    currs.Sort.SortFields.Add Key:=rngSortKey _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With currs.Sort
        .SetRange rngSort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '>2>>>add empty rows & apply header
    oldcompany = ""
    rngsize = rngSort.Columns.Count
    i = 1
    Do While i < rngSort.Rows.Count
        i = i + 1
        If rngSort.Cells(i, 1).Value <> oldcompany Then
            oldcompany = rngSort.Cells(i, 1).Value
            'insert a blank row
            rngSort.Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
           
            'merge cells
            rngSort.Rows(i).Cells.Offset(0, 1).Resize(1, rngsize - 1).Merge
            
            'set merged value
            rngSort.Rows(i).Cells(2).Value = rngSort.Rows(i + 1).Cells(1).Value
            rngSort.Rows(i).Cells(2).HorizontalAlignment = xlCenter
            rngSort.Rows(i).Cells(2).VerticalAlignment = xlBottom
            rngSort.Rows(i).Cells(2).Font.Bold = True
        End If
    Loop
    
End Sub

Select allOpen in new window