Pivottables work with numbers (sum of, max of, average of). They won't work
with text.
And I don't understand how Name 1 can have both course 1 and course 4 as its
first choice. I'm guessing that this is an error in your post--each person can
have at most one first choice, at most one 2nd choice, ...
If that's true, then this worked ok in my testing:
Option Explicit
Sub testme()
Dim InWks As Worksheet
Dim TempWks As Worksheet
Dim OutWks As Worksheet
Dim TempTable As Range
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim oRow As Long
Dim res As Variant
Dim myFormula As String
Set InWks = Worksheets("Sheet1")
Set TempWks = Worksheets.Add
Set OutWks = Worksheets.Add
TempWks.Range("A1").Resize(1, 3).Value _
= Array("Name", "Choice", "Course")
oRow = 1
With InWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2
For iRow = FirstRow To LastRow
LastCol = .Cells(iRow, .Columns.Count).End(xlToLeft).Column
For iCol = FirstCol To LastCol
If Trim(.Cells(iRow, iCol).Value) = "" Then
'skip it
Else
oRow = oRow + 1
TempWks.Cells(oRow, "A").Value = .Cells(iRow, iCol).Value
TempWks.Cells(oRow, "B").Value = .Cells(iRow, "A").Value
TempWks.Cells(oRow, "C").Value = .Cells(1, iCol).Value
End If
Next iCol
Next iRow
End With
With TempWks
.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).AdvancedFilter _
action:=xlFilterCopy, criteriarange:="", _
copytorange:=OutWks.Range("A1"), unique:=True
.Range("B1", .Cells(.Rows.Count, "B").End(xlUp)).AdvancedFilter _
action:=xlFilterCopy, criteriarange:="", _
copytorange:=OutWks.Range("b1"), unique:=True
Set TempTable = .Range("a2", .Cells(.Rows.Count, "C").End(xlUp))
End With
With OutWks
.Range("b2", .Cells(.Rows.Count, "B").End(xlUp)).Copy
.Range("C1").PasteSpecial Transpose:=True
.Range("b1").EntireColumn.Delete
'fill in the data portion of this table with a formula like:
'=INDEX(Sheet10!$C$2:$C$10,
' MATCH(1,((Sheet10!$A$2:$A$10=$A2)*(Sheet10!$B$2:$B$10=B$1)),0))
myFormula = "=index(" & TempTable.Columns(3).Address(external:=True) _
& ",match(1,((" & TempTable.Columns(1).Address(external:=True) _
& "=$a2)*(" & TempTable.Columns(2).Address(external:=True) _
& "=b$1)),0))"
.Range("B2").FormulaArray = myFormula
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("B2").AutoFill _
Destination:=.Range("B2", .Cells(2, LastCol)), Type:=xlFillCopy
.Range("B2", .Cells(2, LastCol)).AutoFill _
Destination:=.Range("B2", .Cells(LastRow, LastCol)), _
Type:=xlFillCopy
With .Range("b2", Cells(LastRow, LastCol))
.Copy
.PasteSpecial Paste:=xlPasteValues
.Replace What:="#n/a", _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
End With
End With
With Application
.CutCopyMode = False
.DisplayAlerts = False
TempWks.Delete
.DisplayAlerts = True
End With
End Sub
If you're new to macros:
Debra Dalgleish has some notes how to implement macros here:
http://www.contextures.com/xlvba01.html
David McRitchie has an intro to macros:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
Ron de Bruin's intro to macros:
http://www.rondebruin.nl/code.htm
(General, Regular and Standard modules all describe the same thing.)
