Pasting Data for samples based on their Test and ID - excel

Question

I have a data sheet with Sample IDs, Test type, and Test results all in three separate columns(A,B,C).
Some samples IDs are listed multiple times, as they all receive different tests.
The three columns of Sample IDs, Test Type, and Test Results are on Sheet 1.
I paste the Sample ID son sheet 2 (only one iteration of each) down column A, and the test types across Row 1.
How do I paste the individual test result data in the correct position on the sheet?
Example: Sample 1 is the Y value and Test-type 1 is the Y axis.
I need to copy the test results and paste them according to sample ID and test type on another sheet.
Every time this workbook is to be used, the sample IDs and test type will change.
This is the code to paste the Sample IDs down Column A on Sheet2 and Test Type across row 1 on sheet 2.
Sub Transpose1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wkb1 As Workbook
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Raw Data")
'Where the data is stored
Set sht2 = wkb1.Sheets("TestResultTable")
'This is where everything is to be pasted
sht2.Range("B2:Z4200").ClearContents
sht1.Range("A1:A4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"A1"), Unique:=True
'Sample IDs pasted with only one iteration of each sample
sht1.Range("B1:B4200").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sht2.Range( _
"B2"), Unique:=True
'Test Type pasted on sheet2 to be copied again and pasted horizontally
sht2.Range("B3:B4200").Copy
sht2.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
sht2.Range("B2:B4200").ClearContents
'The Test results are in sht1 column C
End Sub
The results will not be this organized and A,B,C,D etc. This was to hide proprietary information.
Screenshot of example data and format

Answer 1

A Basic VBA Pivot
Sub BasicPivot()
' s - Source (read from)
Const sName As String = "Raw Data"
Const sFirstCellAddress As String = "A1"
Const srCol As Long = 1
Const scCol As Long = 2
Const svCol As Long = 3
' d - Destination (write to)
Const dName As String = "TestResultTable"
Const dFirstCellAddress As String = "A1"
Const dFirstColumnHeader As String = ""
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' 1.) Write the source data to an array.
' a) Reference the source worksheet.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
' b) Reference the source range.
Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
' c.) Write the values from the source range to an array.
Dim sData As Variant: sData = srg.Value
' 2.) Use dictionaries to get the unique row and column labels.
' a) Define the row dictionary.
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1
' b) Define the column dictionary.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim dc As Long: dc = 1
' c) Loop through the rows of the array and write the unique
' row and column labels to the dictionaries.
Dim Key As Variant
Dim sr As Long
For sr = 2 To srCount
Key = sData(sr, srCol)
If Not rDict.Exists(Key) Then
dr = dr + 1
rDict(Key) = dr
End If
Key = sData(sr, scCol)
If Not cDict.Exists(Key) Then
dc = dc + 1
cDict(Key) = dc
End If
Next sr
' 3.) Write the result to an array.
' a) Define the array.
Dim drCount As Long: drCount = rDict.Count + 1
Dim dcCount As Long: dcCount = cDict.Count + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' b) Write the first column header.
Dim dfHeader As String
If Len(dFirstColumnHeader) = 0 Then
dfHeader = CStr(srg.Cells(1).Value)
Else
dfHeader = dFirstColumnHeader
End If
dData(1, 1) = dfHeader
' c) Write the row labels.
dr = 1
For Each Key In rDict.Keys
dr = dr + 1
dData(dr, 1) = Key
Next Key
' d) Write the column labels.
dc = 1
For Each Key In cDict.Keys
dc = dc + 1
dData(1, dc) = Key
Next Key
' e) Write the values.
For sr = 2 To srCount
dData(rDict(sData(sr, srCol)), cDict(sData(sr, scCol))) _
= sData(sr, svCol)
Next sr
' 4.) Write the results to the destination.
' a) Reference the destination worksheet.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
' b) Clear its cells.
dws.UsedRange.Clear
' c) Write the values from the array to the destination range.
With dws.Range(dFirstCellAddress).Resize(, dcCount)
.Resize(drCount).Value = dData
End With
' 5.) Inform.
MsgBox "Pivot has finished.", vbInformation
End Sub