Filtro serch text e autofit rows su celle unite

Private Sub Worksheet_Change(ByVal Target As Range)
ur = ActiveSheet.Cells(Rows.count, 4).End(xlUp).Row
If Not Intersect(Target, Range("A2")) Is Nothing Then
  If Target.Value = "" Then
    Sheets("Marius").ShowAllData
    Sheets("Marius").Cells(2, 1).Select
  Else
    Call Filtro
  End If
End If
End Sub

Option Explicit

Sub Filtro() 'by Marius44
Dim rng As Range, cella As Range
Dim ur As Long, x As Long, i As Long, a As Long, count As Long, j As Long
ur = Cells(Rows.count, 4).End(xlUp).Row
Set rng = Range("A5:D" & ur)
For Each cella In rng
  x = cella.MergeArea.count         'determino quante celle sono unite
  If cella.MergeCells = True Then   'se la cella è unita allora...
    cella.UnMerge                   'divido
      For i = 1 To x - 1            'riporto il valore su tutte le celle divise
        cella.Offset(i, 0) = cella.Value
      Next i
    End If
  Next cella
  'eseguo il filtro
  Range("A5:D" & ur).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
    Range("A1:A2"), Unique:=False
  'ripristino le celle unite
  a = 1
  Application.DisplayAlerts = False
  For j = 1 To 3    'per colonna
    For i = 6 To ur 'per riga
ripeti:
      If Cells(i, j) = Cells(i + a, j) Then
        count = count + 1
        a = a + 1
        GoTo ripeti
      ElseIf Cells(i, j) <> Cells(i + 1, j) Then
        Range(Cells(i - a + 1, j), Cells(i, j)).Merge
        a = 1
      End If
    Next i
  Next j
  Application.DisplayAlerts = True
End Sub

Option Explicit

Sub Filtro() 'by Marius44

'adattata per Foglio2

Dim rng As Range, cella As Range
Dim ur As Long, x As Long, i As Long, a As Long, count As Long, j As Long
ur = Cells(Rows.count, 4).End(xlUp).Row
Set rng = Range("A2:D" & ur)
For Each cella In rng
  x = cella.MergeArea.count         'determino quante celle sono unite
  If cella.MergeCells = True Then   'se la cella è unita allora...
    cella.UnMerge                   'divido
      For i = 1 To x - 1            'riporto il valore su tutte le celle divise
        cella.Offset(i, 0) = cella.Value
      Next i
    End If
  Next cella
  'eseguo il filtro
  Range("A2:D" & ur).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
    Range("F1:F2"), Unique:=False
  'ripristino le celle unite
  a = 1
  Application.DisplayAlerts = False
  For j = 1 To 3    'per colonna
    For i = 3 To ur 'per riga
ripeti:
      If Cells(i, j) = Cells(i + a, j) Then
        count = count + 1
        a = a + 1
        GoTo ripeti
      ElseIf Cells(i, j) <> Cells(i + 1, j) Then
        Range(Cells(i - a + 1, j), Cells(i, j)).Merge
        a = 1
      End If
    Next i
  Next j
  Application.DisplayAlerts = True
End Sub