automatizzare unione celle

Public uriga As Long

Sub ordina_unisci()
uriga = Cells(Rows.Count, 3).End(xlUp).Row + 1
ele = "A1:D" & uriga
Cells(uriga, 1) = "zz": Cells(uriga, 2) = "zz"
'divide le celle unite in col.A
cln = "A:A"
Call divide(cln)
'divide le celle unite in col.B
cln = "B:B"
Call divide(cln)
'ordina per capo e per collaboratore
Range(ele).Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'unisce per capo
Call unione(1)
'unisce per collaboratore
Call unione(2)
Range(Cells(uriga, 1), Cells(uriga, 2)).ClearContents
Cells(1, 1).Select
MsgBox "Fatto!", 0, "Avviso"
End Sub

Sub divide(ByVal cln As String)
Columns(cln).Select
    Selection.UnMerge
    For i = 2 To uriga
        nom1 = Cells(i, cln)
            For j = i + 1 To uriga
            If Cells(j, cln) = "" Then
                Cells(j, cln) = nom1
            Else
                i = j - 1
                Exit For
            End If
        Next j
    Next i
End Sub

Sub unione(ByVal cln As Integer)
For i = 2 To uriga - 1
    nom1 = Cells(i, cln)
    For j = i + 1 To uriga
        nom2 = Cells(j, cln)
        If nom2 = nom1 Then
            GoTo 1
        ElseIf nom1 <> nom2 Or nom2 = "zz" Then
            Range(Cells(i, cln), Cells(j - 1, cln)).Select
            With Selection
                .ClearContents
                .VerticalAlignment = xlCenter
                .Merge
                For Each c In Selection
                    If c.Value = "" Then c.Value = nom1
                    'mette la riga in basso
                    c.Borders(xlEdgeBottom).LineStyle = xlContinuous
                Next c
            End With
            i = j - 1: nom1 = "": nom2 = "": Exit For
        End If
1   Next j
Next i
End Sub