Fill cells based on data in adjacent cells

[Ally_D]

Hi all, I have what I think is quite a basic macro to write but I stupidly can't quite get it right.

I have a list of preferences from people sorted into columns with their preference number 1-3 in the top row. I am using a named range for each column of data; names are "Pref_1" (cells A1:A5), "Pref_2" (cells B1:B5), "Pref_3" (cells C1:C5). Now I to create a vertical list of the preferences with the preference number entered in the first column. For simplicity I have recreated a simple example of what I'm trying to do using fruits as the preference variables. Orange cells are the ones that need to be copied/filled.

• The first part of my macro collects all of the preferences variables (fruits) from the ranges and lists them vertically in column B. This is working fine.
• The macro I'm struggling with needs to search all of the named ranges for the name of the fruit, copy the preference value from the top row and paste it in column A against the relevant fruit. For example, the preference number for apple is 1, banana is 3, grape is 1 etc.

I would really appreciate your help.

Hopefully I've explained this clearly but let me know if not.

Book2
	A	B	C
1	1	2	3
2	Apple	Orange	Banana
3	Pear	Pineapple	Stawberry
4	Kiwi	Melon	Mango
5	Grape
6
7
8	Preferences	Fruit
9		Apple
10		Banana
11		Grape
12		Kiwi
13		Mango
14		Melon
15		Orange
16		Pear
17		Pineapple
18		Stawberry
Sheet1

 

[MARK858]

Maybe...

Sub Ally_D()
    With Sheets("Sheet1").Range("A9:A18")
        .Formula = "=INDEX($A$1:$C$1,SUMPRODUCT(MAX(($A$2:$C$5=B9)*(COLUMN($A$2:$C$5))))-COLUMN($A$1)+1)"
        .Value = .Value
    End With

End Sub

 

[Sam_D_Ben]

Another approach,

Sub AssignPreferences()
    Dim ws As Worksheet, fruitHdr As Range, prefHdr As Range, fruitList As Range, c As Range
    Dim rngPref1 As Range, rngPref2 As Range, rngPref3 As Range
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set fruitHdr = ws.Cells.Find("Fruit", LookAt:=xlWhole)
    Set prefHdr = ws.Cells.Find("Preferences", LookAt:=xlWhole)
    If fruitHdr Is Nothing Or prefHdr Is Nothing Then Exit Sub

    Set fruitList = ws.Range(fruitHdr.Offset(1), ws.Cells(Rows.Count, fruitHdr.Column).End(xlUp))
    ws.Range(prefHdr.Offset(1), prefHdr.Offset(fruitList.Rows.Count)).ClearContents
    Set rngPref1 = ws.Range("A1:A5"): Set rngPref2 = ws.Range("B1:B5"): Set rngPref3 = ws.Range("C1:C5")

    For Each c In fruitList
        c.Offset(, -1).Value = IIf(Not IsError(Application.Match(c, rngPref1, 0)), 1, _
                              IIf(Not IsError(Application.Match(c, rngPref2, 0)), 2, _
                              IIf(Not IsError(Application.Match(c, rngPref3, 0)), 3, "Not Found")))
    Next
End Sub