Create a list according what i choose in A1!

Hi alpa

This Code in the attached creates a Dynamic Named Range called "Customers" which is used for Data Validation in A1

Option Explicit

Private Sub Workbook_Open()
    ActiveWorkbook.Names.Add Name:="Customers", RefersTo:= _
            "=OFFSET(PriceList!$A$2,0,0,(COUNTA(PriceList!$A:$A)-1),1)"
End Sub

This Code in the attached then fires each time A1 changes

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Rng As Range, c As Range, cel As Range
    Dim LC As Long, cnt As Long

    Set ws1 = ActiveSheet
    Set ws2 = Sheets("PriceList")
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    If Target.Address = "$A$1" Then

        Application.EnableEvents = False
        Columns(4).ClearContents
        cnt = 4
        With ws2
            LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious).Column
        End With

        With ws2.Columns(1)
            Set c = .Find(Target.Value, LookIn:=xlValues)
            If Not c Is Nothing Then
                Set Rng = .Range(.Cells(c.Row, 2), .Cells(c.Row, LC))
                For Each cel In Rng
                    If Not cel.Value = "" Then
                        ws1.Cells(cnt, "D").Value = .Cells(1, cel.Column).Value
                        cnt = cnt + 1
                    End If
                Next cel
            End If
        End With
        Application.EnableEvents = True
    End If
End Sub

Hi alpa

To do this

I need the validation list in B6

Change this line of Code

If Target.Address = "$A$1" Then

to

If Target.Address = "$B$6" Then

Here's the Commented Code

Option Explicit

Private Sub Workbook_Open()
    'add a Dynamic Named Range for all Customers in PriceList Column A
    ActiveWorkbook.Names.Add Name:="Customers", RefersTo:= _
            "=OFFSET(PriceList!$A$2,0,0,(COUNTA(PriceList!$A:$A)-1),1)"
End Sub

and

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws1 As Worksheet, ws2 As Worksheet      ')
    Dim Rng As Range, c As Range, cel As Range  ') Dimension all Variables
    Dim LC As Long, cnt As Long                 ')

    Set ws1 = ActiveSheet                       ')Assign Sheet Names
    Set ws2 = Sheets("PriceList")               ')to Variables
    If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub 'If more than one Cell changes get out
    If Target.Address = "$B$6" Then             ' If Cell B6 changes then do stuff

        Application.EnableEvents = False        'Turn off Event Code
        Columns(4).ClearContents                'Clear the landing zone (Column D)
        cnt = 4                                 'This is the first Row of the landing zone
        With ws2                                'Using ws2
            LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                    SearchDirection:=xlPrevious).Column ')Find the last Column in ws2
        End With

        With ws2.Columns(1)
            Set c = .Find(Target.Value, LookIn:=xlValues) 'Using ws2, first Column find the value of Cell B6
            If Not c Is Nothing Then                      'if you find it
                Set Rng = .Range(.Cells(c.Row, 2), .Cells(c.Row, LC)) 'set the Search Range
                For Each cel In Rng 'look at each Cell to the right of c
                    If Not cel.Value = "" Then 'if it's not blank
                        ws1.Cells(cnt, "D").Value = .Cells(1, cel.Column).Value 'place the Header in the landing zone
                        cnt = cnt + 1 'set the landing zone to the next Row
                    End If
                Next cel                'find the next item in the Search Range
            End If
        End With
        Application.EnableEvents = True 'turn Event Code back on
    End If
End Sub

You're welcome...glad I could help. Thanks for the Rep.