Sub NewMacros()
Dim f, i&, Coll As New Collection
On Error Resume Next
With ActiveWorkbook.ActiveSheet.UsedRange.Offset(4) 'т.е. начинаем перебор с 5-й строки
For Each f In .Columns(18).Value
If f <> "" Then Coll.Add CStr(f), CStr(f)
Next f

'Если работа с коллекцией далее неприемлема, то перебросить её в массив
ReDim NewMyArray(1 To Coll.Count)
i = 1
For Each f In Coll
NewMyArray(i) = f
i = i + 1
Next

NewMyArray = SortedRezult(NewMyArray)
For Each f In NewMyArray
.AutoFilter Field:=18, Criteria1:=f
Range("R3").FormulaR1C1 = "=GetCriteria(R[2]C)"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
Next f
End With
End Sub

Private Function SortedRezult(Massiv() As Variant)
Dim nnn&, iii&
Dim Tmp1 As Variant
Dim Tmp2 As Variant
' On Error Resume Next
If (Not Not Massiv) <> 0 Then 'Double negation allows checking that the array is not empty
For iii = LBound(Massiv) To UBound(Massiv) Step 1
Tmp1 = Massiv(iii)
For nnn = iii To UBound(Massiv)
If Massiv(nnn) < Tmp1 Then
Tmp1 = Massiv(nnn): Tmp2 = Massiv(iii)
Massiv(iii) = Tmp1: Massiv(nnn) = Tmp2
End If
Next nnn
Next iii
End If
SortedRezult = Massiv
End Function