There is an excel issue where we have one column with values like below and we want the respective values to go into corresponding new columns like allocation, primary purpose etc.
data is like
Allocation: Randomized|Endpoint Classification: Safety/Efficacy Study|Intervention Model: Parallel Assignment|Masking: Double Blind (Subject, Caregiver)|Primary Purpose: Treatment
Allocation: Randomized|Primary Purpose: Treatment
Allocation: Randomized|Intervention Model: Parallel Assignment|Masking: Open Label|Primary Purpose: Treatment
There are many such rows like this.
First use text to columns to split data using | delimiter.
Assuming data layout as in screenshot:
Add the following in A6 and drag across/down as required:
=IFERROR(MID(INDEX(1:1,0,(MATCH("*"&A$5&"*",1:1,0))),FIND(":",INDEX(1:1,0,(MATCH("*"&A$5&"*",1:1,0))),1)+2,1000),"")
It uses the MATCH/INDEX function to get the text of cell containing the heading, then uses MID/FIND function to get the text after the :. The whole formula is then enclosed in IFERROR so that if certain rows do not contain a particular header item, it returns a blank instead of #N/A's
You did not ask for a VBA solution, but here is one anyway.
Determine the column headers by examining each line and generate a unique list of the headers, storing it in a dictionary
You can add a routine to sort or order the headers
Create a "results" array and write the headers to the first row, using the dictionary to store the column number for later lookup
examine each line again and pull out the value associated with each column header, populating the correct slot in the results array.
write the results array to a "Results" worksheet.
In the code below, you may need to rename the worksheet where the source data resides. The Results worksheet will be added if it does not already exist -- feel free to rename it.
Test this on a copy of your data first, just in case.
Be sure to set the reference to Microsoft Scripting Runtime (Tools --> References) as indicated in the notes in the code.
Option Explicit
'Set References
' Microsoft Scripting Runtime
Sub MakeColumns()
Dim vSrc As Variant, vRes As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim dHdrs As Dictionary
Dim V As Variant, W As Variant
Dim I As Long, J As Long
Set wsSrc = Worksheets("Sheet1")
'Get source data
With wsSrc
vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'Set results sheet and range
On Error Resume Next
Set wsRes = Worksheets("Results")
If Err.Number = 9 Then
Worksheets.Add.Name = "Results"
End If
On Error GoTo 0
Set wsRes = Worksheets("Results")
Set rRes = wsRes.Cells(1, 1)
'Get list of headers
Set dHdrs = New Dictionary
dHdrs.CompareMode = TextCompare
'Split each line on "|" and then ":" to get header/value pairs
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "|")
For J = 0 To UBound(V)
W = Split(V(J), ":") 'W(0) will be header
If Not dHdrs.Exists(W(0)) Then _
dHdrs.Add W(0), W(0)
Next J
Next I
'Create results array
ReDim vRes(0 To UBound(vSrc, 1), 1 To dHdrs.Count)
'Populate Headers and determine column number for lookup when populating
'Could sort or order first if desired
J = 0
For Each V In dHdrs
J = J + 1
vRes(0, J) = V
dHdrs(V) = J 'column number
Next V
'Populate the data
For I = 1 To UBound(vSrc, 1)
V = Split(vSrc(I, 1), "|")
For J = 0 To UBound(V)
'W(0) is the header
'The dictionary will have the column number
'W(1) is the value
W = Split(V(J), ":")
vRes(I, dHdrs(W(0))) = W(1)
Next J
Next I
'Write the results
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
With .Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
If you have not used macros before, to enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), opens the macro dialog box. Select the macro by name, and RUN.
Related
I am new to VBA and am trying to copy the column from Row 2 onwards where the column header (in Row 1) contains a certain word- "Unique ID".
Currently what I have is:
Dim lastRow As Long
lastRow = ActiveWorkbook.Worksheets("Sheets1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheets1").Range("D2:D" & lastRow).Copy
But the "Unique ID" is not always in Column D
You can try following code, it loops through first row looking for a specified header:
Sub CopyColumnWithHeader()
Dim i As Long
Dim lastRow As Long
For i = 1 To Columns.Count
If Cells(1, i) = "Unique ID" Then
lastRow = Cells(Rows.Count, i).End(xlUp).Row
Range(Cells(2, i), Cells(lastRow, i)).Copy Range("A2")
Exit For
End If
Next
End Sub
When you want to match info in VBA you should use a dictionary. Additionally, when manipulating data in VBA you should use arrays. Although it will require some learning, below code will do what you want with minor changes. Happy learning and don't hesitate to ask questions if you get stuck:
Option Explicit
'always add this to your code
'it will help you to identify non declared (dim) variables
'if you don't dim a var in vba it will be set as variant wich will sooner than you think give you a lot of headaches
Sub DictMatch()
'Example of match using dictionary late binding
'Sourcesheet = sheet1
'Targetsheet = sheet2
'colA of sh1 is compared with colA of sh2
'if we find a match, we copy colB of sh1 to the end of sh2
'''''''''''''''''
'Set some vars and get data from sheets in arrays
'''''''''''''''''
'as the default is variant I don't need to add "as variant"
Dim arr, arr2, arr3, j As Long, i As Long, dict As Object
'when creating a dictionary we can use early and late binding
'early binding has the advantage to give you "intellisense"
'late binding on the other hand has the advantage you don't need to add a reference (tools>references)
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
dict.CompareMode = 1 'textcompare
arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source, assuming we have data as of A1
arr2 = Sheet2.Range("A1").CurrentRegion.Value2 'load source2, assuming we have data as of A1
'''''''''''''''''
'Loop trough source, calculate and save to target array
'''''''''''''''''
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can write these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediate array (arr3) to store the results
'We use a "dictionary" to match values in vba because this allows to easily check the existence of a value
'Together with arrays and collections these are probably the most important features to learn in vba!
For j = 1 To UBound(arr) 'traverse source, ubound allows to find the "lastrow" of the array
If Not dict.Exists(arr(j, 1)) Then 'Check if value to lookup already exists in dictionary
dict.Add Key:=arr(j, 1), Item:=arr(j, 1) 'set key if I don't have it yet in dictionary
End If
Next j 'go to next row. in this simple example we don't travers multiple columns so we don't need a second counter (i)
'Before I can add values to a variant array I need to redim it. arr3 is a temp array to store matching col
'1 To UBound(arr2) = the number of rows, as in this example we'll add the match as a col we just keep the existing nr of rows
'1 to 1 => I just want to add 1 column but you can basically retrieve as much cols as you want
ReDim arr3(1 To UBound(arr2), 1 To 1)
For j = 1 To UBound(arr2) 'now that we have all values to match in our dictionary, we traverse the second source
If dict.Exists(arr2(j, 1)) Then 'matching happens here, for each value in col 1 we check if it exists in the dictionary
arr3(j, 1) = arr(j, 2) 'If a match is found, we add the value to find back, in this example col. 2, and add it to our temp array (arr3).
'arr3(j, 2) = arr(j, 3) 'As explained above, we could retrieve as many columns as we want, if you only have a few you would add them manually like in this example but if you have many we could even add an additional counter (i) to do this.
End If
Next j 'go to the next row
'''''''''''''''''
'Write to sheet only at the end, you could add formatting here
'''''''''''''''''
With Sheet2 'sheet on which I want to write the matching result
'UBound(arr2, 2) => ubound (arr2) was the lastrow, the ubound of the second dimension of my array is the lastcolumn
'.Cells(1, UBound(arr2, 2) + 1) = The startcel => row = 1, col = nr of existing cols + 1
'.Cells(UBound(arr2), UBound(arr2, 2) + 1)) = The lastcel => row = number of existing rows, col = nr of existing cols + 1
.Range(.Cells(1, UBound(arr2, 2) + 1), .Cells(UBound(arr2), UBound(arr2, 2) + 1)).Value2 = arr3 'write target array to sheet
End With
End Sub
I am trying to take a range of values in a number of sets, and write a VBA code to fill in grouped cells with the minimum and maximum values in the range.
Example Table
Group
Value
A
10
A
3
A
5
B
1
B
3
The expected outputs should be a table or cells that say
A Range : 3-10
B Range : 1-3
Obviously, I could do this with a min and max formula, for each set, however, I'm wondering if there's a way to do this in VBA as the number of sets is in excess of a few hundred
You can certainly do this with VBA and/or Power Query, although, as others have written and you are aware, formulas are a viable option.
Source Data
for VBA:
Read the source data into a VBA array for fastest processing
create a class module to hold the minumum and maximum values
Group the ranges using a Dictionary, which in turn holds the class object
Create a results array and write it to the worksheet.
Class Module
'ReNAME this "cGroup"
Option Explicit
Private pMin As Long
Private pMax As Long
Public Property Get Min() As Long
Min = pMin
End Property
Public Property Let Min(Value As Long)
pMin = Value
End Property
Public Property Get Max() As Long
Max = pMax
End Property
Public Property Let Max(Value As Long)
pMax = Value
End Property
Regular Module
'Set reference to Microsoft Scripting Runtime
Option Explicit
Sub generateRanges()
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant, v As Variant
Dim I As Long
Dim D As Dictionary, sKey As String
Dim cG As cGroup
'set the source and results worksheets
Set wsSrc = ThisWorkbook.Worksheets("sheet1")
Set wsRes = ThisWorkbook.Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 1)
'read source data into vba array
With wsSrc
vSrc = Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp))
End With
'set dictionary to collect the data
Set D = New Dictionary
D.CompareMode = TextCompare
'iterate through the data
'pull out the min and max of the range
For I = 2 To UBound(vSrc, 1)
sKey = vSrc(I, 1)
Set cG = New cGroup
If Not D.Exists(sKey) Then
cG.Max = vSrc(I, 2)
cG.Min = vSrc(I, 2)
D.Add Key:=sKey, Item:=cG
Else
With D(sKey)
.Max = IIf(.Max > vSrc(I, 2), .Max, vSrc(I, 2))
.Min = IIf(.Min < vSrc(I, 2), .Min, vSrc(I, 2))
End With
End If
Next I
'create the results array
ReDim vRes(0 To D.Count, 1 To 2)
'Column Headers
vRes(0, 1) = "Range"
vRes(0, 2) = "Value"
I = 0
For Each v In D.Keys
I = I + 1
vRes(I, 1) = v & " Range"
vRes(I, 2) = D(v).Min & "-" & D(v).Max
Next v
'write results to results worksheet
With rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
.EntireColumn.Clear
.NumberFormat = "#"
.Value = vRes
.Style = "Output" 'not internationally aware
.EntireColumn.AutoFit
End With
End Sub
Or, using Power Query (which I prefer because its shorter and easier to program) available in Windows Excel 2010+ and Office 365:
Select some cell in your Data Table
Data => Get&Transform => from Table/Range
When the PQ Editor opens: Home => Advanced Editor
Make note of the Table Name in Line 2
Paste the M Code below in place of what you see
Change the Table name in line 2 back to what was generated originally.
Read the comments and explore the Applied Steps to understand the algorithm
M Code
let
//Read in the table
// Change Table name in next line to actual table name
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
//type the data
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Group", type text}, {"Value", Int64.Type}}),
//Group by "Group"
// then generate the min-max string
#"Grouped Rows" = Table.Group(#"Changed Type", {"Group"}, {{"Value",
each Text.From(List.Min([Value])) & "-" & Text.From(List.Max([Value])), Text.Type }
}),
//Add the word " Range" to the Group
addRange = Table.TransformColumns(#"Grouped Rows",{"Group", each _ & " Range", Text.Type})
in
addRange
Either produces the same results from your data:
Indeed, VBA isn't the best solution in this case because a single formula can extract all the data you want. There is no need to make a different formula for each group.
=MINIFS(INDEX(Data,,2),INDEX(Data,,1),H2) & " - " & MAXIFS(INDEX(Data,,2),INDEX(Data,,1),H2)
The formula for the dynamic named range is =OFFSET(Sheet1!$A$2,0,0,COUNTA(Sheet1!$A:$A)-1,2)
If you want to go with formula then could try below formula with Excel365.
D2=UNIQUE(A2:A6)
E2=MINIFS(B2:B6,A2:A6,D2#)&"-"&MAXIFS(B2:B6,A2:A6,D2#)
I am now trying to creating several worksheets and copying data from an existing worksheet to the worksheet that I just created.
This is what I have tried so far:
Sub CreateTemplate()
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "CUST001"
Worksheets("Template").Cells.Copy Worksheets("CUST001").Cells
Worksheets("CUST001").Select
Range("C4") = "='CDE Information'!R[-2]C[-2]"
Range("C5") = "='CDE Information'!R[-3]C[-1]"
Range("C6") = "1111"
Range("C7") = "2222"
End Sub
This is an example of a table that I want to copy.
Table
I also want to create the worksheets and name them by the values of each row in column A.
So, it seems to me that I should do something with loops but I have no idea about that.
Can anyone help me out? Thank you in advance!
Welcome to stack. Try this:
Option Explicit
Sub copyWs()
Dim arr, j As Long
With Sheet1
arr = .Range("A1").CurrentRegion.Value2 'get all data in memory
For j = 1 To UBound(arr) 'traverse rows
.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
Sheets(ActiveWorkbook.Sheets(Worksheets.Count).Index).Name = arr(j, 1) 'name the last added ws
Next j
End With
End Sub
Now that we already have an array with all data we can also copy only part of our data to a new sheet instead of copying the whole sheet. To achieve this we'll just create a blank sheet first:
Sheets.Add After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
When iterating an array we'll use 2 "counter" variables. 1 to go trough the lines, 1 to go trough the columns.
Dim j As Long, i As Long 'initiate our counter vars
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
Next i
Next j
The "Ubound" function allows us to get the total nr of rows and columns.
Dim arr2
ReDim arr2(1 To 1, 1 To UBound(arr)) '=> we only need 1 line but all columns of the source, as we cannot dynamically size an array with the "dim", we redim
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can dump these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediant array to store the full line
arr2(1, i) = arr(j, i)
Next i
'when we have all the columns we dumb to the sheet
With Sheets(arr(j, 1)) 'the with allows us the re-use the sheet name without typing it again
.Range(.Cells(1, 1), .Cells(UBound(arr2), UBound(arr2, 2))).Value2 = arr2 'the ubound function allows us to size the "range" to the same size as our array, once that's done we can just dumb it to the sheet
End With
Next j
I am using an IF statement in Excel to search for portions of text in the previous column in order to assign a supplier and category to the expense.
Supplier Column
=IF(ISNUMBER(SEARCH("tit",[#Description])),"TITAN",IF(ISNUMBER(SEARCH("Sol",[#Description])),"Soltrack",IF(ISNUMBER(SEARCH("coin",[#Description])),"Coin",IF(ISNUMBER(SEARCH("gree",[#Description])),"Green Dream Projects",IF(ISNUMBER(SEARCH("sars V",[#Description])),"SARS VAT",IF(ISNUMBER(SEARCH("sars p",[#Description])),"SARS PAYE",IF(ISNUMBER(SEARCH("acb",[#Description])),"Debit Order","")))))))
Category Column
the next column then has the following to get the category of the supplier
=IF(ISNUMBER(SEARCH("TITAN",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Soltrack",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Coin",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("Green Dream Projects",[#Payee])),"Direct Operating Cost",IF(ISNUMBER(SEARCH("SARS VAT",[#Payee])),"VAT",IF(ISNUMBER(SEARCH("SARS PAYE",[#Payee])),"PAYE",IF(ISNUMBER(SEARCH("Debit Order",[#Payee])),"Debit Order","")))))))
this is working great, but seems i have reached the limit (7) of IF statements I can use in one formula?
I have created the below function to search for text "tit" and if it matches it updates the Payee column.
'excel if range of cells contains specific text vba
Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Set Rng = Range("B2:B572") ' You can change this
specificText = "*tit*" ' You can change this
For Each Cell In Rng.Cells
If UCase(Cell.Value) Like "*" & UCase(specificText) & "*" Then
Cell.Offset(0, 1) = "Titan"
Else
Cell.Offset(0, 1) = ""
End If
Next
End Sub
Would I need to create a new specificText = "*tit*" for each of the keywords and also a whole section for each of the "For Each" functions?
Dictionary Solution
The first idea is to use a dictionary Replacements and add all the serach/replace pairs there. This has one huge disadvantage. It is against the good practice to not mix logic (code) and data. Good practice would be to put the data not into the code but into a worksheet (see next solution).
Option Explicit
Public Sub MacroToCheckIfRangeOfCellsContainsSpecificText_vba()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements As Object
Set Replacements = CreateObject("Scripting.Dictionary")
With Replacements
.Add "tit", "Titan"
.Add "sol", "Soltrack"
'add more here
End With
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim Key As Variant
For Each Key In Replacements.Keys
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Key) & "*" Then
OutputValues(iRow, 1) = Replacements(Key)
Exit For 'we don't need to test for the others if we found a key
End If
Next Key
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
Worksheet Solution
The better solution would be to create a new worksheet Replacements as below:
This can easily be edited by anyone and you don't need to fiddle with the code later if you want to delete or add pairs.
Public Sub ImprovedCheckUsingWorksheet()
Dim RngToCheck As Range
Set RngToCheck = ThisWorkbook.Worksheets("Sheet1").Range("B2:B572") ' specify in which workbook and worksheet
Dim Replacements() As Variant 'read replacements from worksheet
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "B").End(xlUp)).Value 'read input values into array
Dim InputValues() As Variant
InputValues = RngToCheck.Value 'read input values into array
Dim OutputValues() As Variant 'create an output array (same size as RngToCheck)
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To 1)
Dim iRow As Long
For iRow = 1 To UBound(OutputValues, 1)
Dim rRow As Long
For rRow = 1 To UBound(Replacements, 1)
If UCase(InputValues(iRow, 1)) Like "*" & UCase(Replacements(rRow, 1)) & "*" Then
OutputValues(iRow, 1) = Replacements(rRow, 2)
Exit For 'we don't need to test for the others if we found a key
End If
Next rRow
Next iRow
'write output values from array next to input values in the cells
RngToCheck.Offset(ColumnOffset:=1).Value = OutputValues
End Sub
For a 3ʳᵈ column in your replacements worksheet you would need to adjust the following line to be until column "C":
Replacements = ThisWorkbook.Worksheets("Replacements").Range("A2", ThisWorkbook.Worksheets("Replacements").Cells(Rows.Count, "C").End(xlUp)).Value 'read input values into array
and the output values need another column too (second parameter needs to go 1 To 2):
ReDim OutputValues(1 To RngToCheck.Rows.Count, 1 To UBound(Replacements, 2) - 1) 'this works for any amount of columns as it reads the column count from the `Replacements`
the data needs to be written
OutputValues(iRow, 1) = Replacements(rRow, 2) 'first output column
OutputValues(iRow, 2) = Replacements(rRow, 3) 'second output column
and writing the output values needs to be adjusted too:
RngToCheck.Offset(ColumnOffset:=1).Resize(ColumnSize:=UBound(OutputValues, 2)).Value = OutputValues 'this works for any amount of columns as it reads the column count from `OutputValues`
Formula Solution
But if you have your data in a worksheet Replacements like above, and you don't rely an a partial match. Then you don't need VBA and can easily use a formula instead to look it up:
=IFERROR(INDEX(Replacements!B:B,MATCH(B:B,Replacements!A:A,0)),"")
I have some lines (rows) in excel in the following form :
I need to transform it to the following form :
I'm not a good user of MS Excel and I am using the french version.
Thanks
Give this a try
Option Explicit
Public Sub MergeRows()
Dim rng As Range
Dim dict As Object
Dim tmp As Variant
Dim i As Long, j As Long
Dim c, key
Set dict = CreateObject("Scripting.dictionary")
dict.CompareMode = vbTextCompare
' Change this to where your source data is
With Sheet17
Set rng = .Range(.Cells(2, 10), .Cells(.Cells(.Rows.Count, 10).End(xlUp).Row, 10))
End With
For Each c In rng
If Not dict.exists(c.Value2) Then
ReDim tmp(1 To 3)
dict.Add key:=c.Value2, Item:=tmp
End If
j = 1
tmp = dict(c.Value2)
Do
If Not c.Offset(0, j).Value2 = vbNullString Then tmp(j) = c.Offset(0, j).Value2
j = j + 1
Loop Until j > UBound(tmp)
dict(c.Value2) = tmp
Next c
' Change this to where you want your output
With Sheet17.Range("A2")
i = 0
For Each key In dict.keys
.Offset(i, 0).Value2 = key
.Offset(i, 1).Resize(, UBound(dict(key))) = dict(key)
i = i + 1
Next key
End With
End Sub
Fun problem, here's my take using formulae but there's sure to be solutions out there that are better.
It uses three helper columns to the right of your options' columns:
1-Identify which option is chosen by finding the (first) non-blank cell in the row (as per these instructions). Put the first range as your header row (option1, option2, ... optionn) and the second range as your row from option1 through optionn. It should look something like this: =INDEX($K$1:$M$1,MATCH(FALSE,ISBLANK(K2:M2),0)) and note that it should be an array formula (ctrl+shift+enter)
2-Use a simple index+match to register the choice. Assuming the first helper column is in column N, this is: =INDEX(k2:m2,MATCH(n2,$k$1:$m$1,0))
3-Concatenate the address and option name to make it possible to look up the address-option combination. This is simply: =J2&N2
Once this is done, you create a simple table with only single Addresses in the left most column and Options as a header row (depending on the number of addresses, you might want to use a pivot table to populate them). Then you have an index-match to find your results:
=INDEX($O$2:$O$6,MATCH($J9&K$8,$P$2:$P$6,0)).
And you should be done.