Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, arr, el, n&
Dim f As Object, arw, em, k&

If Not Intersect(Target, [диапазон1]) Is Nothing Then Exit Sub
Set d = CreateObject("scripting.dictionary")
d.CompareMode = 0
arr = [диапазон1].Value
For Each el In arr
If Not IsEmpty(el) Then d.Item(el) = d.Item(el) + 1
Next
n = Application.Min(Rows.Count - [результат1].Rows(1).Row + 1, UBound(arr) * UBound(arr, 2))
Application.ScreenUpdating = False
With [результат1].Resize(n, 2)
.ClearContents
.Columns(1).Resize(d.Count) = Application.Transpose(d.Keys)
.Columns(2).Resize(d.Count) = Application.Transpose(d.Items)
End With

If Not Intersect(Target, [диапазон2]) Is Nothing Then Exit Sub
Set f = CreateObject("scripting.dictionary")
f.CompareMode = 0
arr = [диапазон2].Value
For Each em In arw
If Not IsEmpty(em) Then f.Item(em) = f.Item(em) + 1
Next
k = Application.Min(Rows.Count - [результат2].Rows(1).Row + 1, UBound(arw) * UBound(arw, 2))
Application.ScreenUpdating = False
With [результат2].Resize(k, 2)
.ClearContents
.Columns(1).Resize(f.Count) = Application.Transpose(f.Keys)
.Columns(2).Resize(f.Count) = Application.Transpose(f.Items)
End With

End Sub