Function ТЕКСТКАК1(text As Range, patter As String) As Boolean
Dim I, arr, S
arr = Intersect(text, text.Parent.UsedRange).Value
    For I = 1 To UBound(arr)
        If arr(I, 1) Like patter Then
        I = I + 1
        End If
        Next
            ТЕКСТКАК1 = I - 1
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Columns("H")) Is Nothing And Target.Count = 1 Then
    arr = Range("C3:H" & Cells(Rows.Count, "H").End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For I = 1 To UBound(arr)
            If arr(I, 6) <> Empty Then iTemp = .Item(Format(arr(I, 1), "mmmm yyyy"))
        Next
        With Worksheets("Лист1")
            .Range("A1:A" & .Cells(.Rows.Count, "H").End(xlUp).Row).ClearContents
        End With
        Worksheets("Лист1").Range("A1").Resize(UBound(.Keys) + 1) = Application.Transpose(.Keys)
    End With
End If
End Sub

Function Уник(ByVal ra As Range) As Variant     On Error Resume Next: Dim cell As Range, coll As New Collection, txt$     For Each cell In ra.Cells         txt$ = Trim(cell): If Len(txt$) Then coll.Add txt$, txt$     Next cell     ReDim newarr(1 To coll.Count, 1 To 1)     For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i     Уник = newarr End Function 

Sub Test2()      '      ActiveSheet.Cells(1, 4).Select      i = 1      Do Until IsEmpty(ActiveCell)         If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then         ActiveCell.Offset(1, 0).Select         Else         Selection.Copy ActiveSheet.cell(i, 1)         i = i + 1         End If        ActiveCell.Offset(1, 0).Select      Loop   End Sub