Location Category Supplier A Computers Company X A Printers Company Y B Computers Company X B Printers Company Y B Software Company Y C Computers Company Y C Software Company Z Computers Printers Software A Company X Company Y B Company X Company Y Company Y C Company Y Company Z SELECT t1.Location, MAX(t1.Computers), MAX(t1.Printers), MAX(t1.Software) FROM ( SELECT t.Location, CASE WHEN t.Category = 'Computers' THEN t.Supplier END Computers, CASE WHEN t.Category = 'Printers' THEN t.Supplier END Printers, CASE WHEN t.Category = 'Software' THEN t.Supplier END Software, FROM YOUR_TABLE t ) t1 GROUP BY t1.Location ' Get table entry from third column of list. TableEntry = Cells(ListRow, 3).Value On Error Resume Next If Err.Number > 0 Then MsgBox Err.Number ' Get position of product name within range of row titles. If TableEntry <> "" Then TableRow = Application.Match(Cells(ListRow, 1), Range("F3:" & MYLastRowAddress), 0) ' 2 rows less than reality ' Get position of product size within range of column titles. TableColumn = Application.Match(Cells(ListRow, 2), Range("G2:" & MYLastColAddress), 0) Set CellToFill = Range("F2").Offset(TableRow, TableColumn) ' If there's already an entry in the cell, separate it from the new entry with a comma and space. If Err.Number = 0 Then If CellToFill.Value <> "" Then CellToFill.Value = CellToFill.Value & "," CellToFill.Value = CellToFill.Value & TableEntry Else CellToFill.Value = TableEntry End If Else MisMatchCounter = MisMatchCounter + 1 Sheets("Errors").Cells(MisMatchCounter, 1).Value = ListRow Sheets("Errors").Cells(MisMatchCounter, 2).Value = Cells(ListRow, 1) Sheets("Errors").Cells(MisMatchCounter, 3).Value = Cells(ListRow, 2) Sheets("Errors").Cells(MisMatchCounter, 4).Value = Cells(ListRow, 3) Sheets("Errors").Cells(MisMatchCounter, 5).Value = Cells(ListRow, 4) End If End If On Error GoTo 0 ListRow = ListRow + 1 Dim TableRow, TableColumn As Integer Dim TableEntry As String Dim CellToFill As Range 'Sheet is called Lijst 'Column A is names for top row 'Column B is names for left column 'Column C is value for Matrix 'Matrix Top Row starts at H1 'Matrix Left Column starts at G2 MatrixLastColAddress = Range("H1").End(xlToRight).Address MatrixLastRow = Range("G65536").End(xlUp).Row LijstReadColumn = 3 LijstCurrentRow = 2 'make 1 if no header is used Do Until Sheets("Lijst").Cells(LijstCurrentRow, 1).Value = "" ' Get table entry from third column of list. TableEntry = Sheets("Lijst").Cells(LijstCurrentRow, LijstReadColumn).Value ' Get position of Employee name within Matrix. TableColumn = Application.Match(Sheets("Lijst").Cells(LijstCurrentRow, 1), Range("H1:" & MatrixLastColAddress), 0) ' Get position of Qualification Name within Matrix titles. TableRow = Application.Match(Sheets("Lijst").Cells(LijstCurrentRow, 2), Range("G2:G" & MatrixLastRow), 0) Set CellToFill = Range("G1").Offset(TableRow, TableColumn) ' If there's already an entry in the cell, separate it from the new entry with a comma and space. If CellToFill.Value <> "" Then CellToFill.Value = CellToFill.Value & "," ' Add the new entry to the cell. CellToFill.Value = CellToFill.Value & TableEntry LijstCurrentRow = LijstCurrentRow + 1 Loop Select Location , Min( Case When Category = 'Computers' Then Supplier End ) As Computers , Min( Case When Category = 'Printers' Then Supplier End ) As Printers , Min( Case When Category = 'Software' Then Supplier End ) As Software From MyTable Group By Location