Pasting Data for samples based on their Test and ID in excel visual basic-CodePudding

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 needed to have (on sheet 2) the Samples IDs pasted (only one iteration of each) down column A, and the test types pasted across Row 1. So far I have managed to accomplish these two things, however I am unsure of how to paste the individual test result data in the correct position on the sheet ex: Sample 1 is the Y value and Test-type 1 is the Y axis for a lack of proper way to explain it. I just need it to copy the test results and paste them according to sample ID and test type on another sheet.

Everytime this workbook is to be used, the sample IDs and test type will change. I am extremely new to VBA (only a couple weeks experience) so do not roast my code too hard haha.

This is what I have so far for pasting the Sample IDs and Test type:


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

Again, this is just the code I have to paste the Sample IDs down Column A on Sheet2 and Test Type across row 1 on sheet 2.

Thank you so much

The results will not be this organized and A,B,C,D etc this was just to hide proprietary information Screenshot of example data and format

CodePudding user response：

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