Sub Utworz_Nazwe_Dla_Listy(zrodlowa As Range, pomocnicza As Range, nazwa As _
    String)
  'Parametry:
  'zrodlowa - pierwsza KOMÓRKA kolumny źródłowej
  'pomocnicza - pierwsza KOMÓRKA kolumny pomocniczej
  'nazwa - NAZWA dla zakresu komórek

  'Procedura na podstawie kolumny (listy nieposortowanej
  'i niecągłej, utworzy, w pomocniczym arkuszu, listę (nazwany
  'zakres) do wykorzystania w sprawdzaniu poprawności.

  'skasowanie poprzedniej listy
   On Error GoTo Utworz_Nazwe_Dla_Listy_Error

  pomocnicza.EntireColumn.ClearContents

  'kopiowanie kolumny źródłowej do pomocniczej
  With zrodlowa.Parent
    .Range(zrodlowa, .Cells(Rows.Count, _
        zrodlowa.Column).End(xlUp)).AdvancedFilter CopyToRange:=pomocnicza, _
        Action:=xlFilterCopy, Unique:=True
  End With

  'sortowanie listy w arkuszu pomocniczym
  With pomocnicza.Parent
    .Range(pomocnicza, .Cells(Rows.Count, pomocnicza.Column).End(xlUp)).Sort _
        Key1:=pomocnicza, Order1:=xlAscending, Header:=xlYes
  End With

  'utworzenie/'odnowienie' nazwy dla zakresu
  pomocnicza.Parent.Range(pomocnicza(2), pomocnicza.End(xlDown)).Name = nazwa

Utworz_Nazwe_Dla_Listy_Exit:
   On Error GoTo 0
   Exit Sub

Utworz_Nazwe_Dla_Listy_Error:

  MsgBox "Error " & Err.Number & " (" & Err.Description & _
      ") in procedure Utworz_Nazwe_Dla_Listy of Module Module1"
  Resume Utworz_Nazwe_Dla_Listy_Exit

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

  On Error GoTo Worksheet_Change_Error

  If Not Intersect(Target, Range("A:A")) Is Nothing Then

    Utworz_Nazwe_Dla_Listy _
        Worksheets("Arkusz1").Range("F1"), _
        Worksheets("TMP").Range("B1"), _
        "ListaA"

  End If

Worksheet_Change_Exit:
  On Error GoTo 0
  Exit Sub

Worksheet_Change_Error:
  MsgBox "Lista wyboru nie może być utworzona!", _
         vbCritical, " B Ł Ą D"

  Resume Worksheet_Change_Exit
End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("A:A")) Is Nothing Then

    Call Create_Val_List
    
End If

End Sub

Option Explicit

Sub Create_Val_List()
    
    With Sheets("Arkusz2")
    
        .Range("A:A").ClearContents
    
        Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter _
            Action:=xlFilterCopy, CopyToRange:=Range("Filt_Dest"), Unique:=True
    
        .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Sort Key1:=.Range("A1"), _
            Order1:=xlAscending, Header:=xlYes
            
        .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Name = "Val_List"
        
    End With
    
End Sub

.Range("A2:A")