Transpose Column Data to Rows

Hi,

Below mentioned code is extracted from my previous Post code provided by forum contributor "WideBoyDixon"-Thanx a lot to him.

The changes that I want is to get a revise the code that produce the output/result as mentioned in "Expected" worksheet.Slight changes are there than that of previous output which has been reflected in"Existing Code Output".Since,I heavily relied on Power Query but have no Code No.in C column those list is not displayed.Hence,now I have to go with this below code.

Public Sub TransposeData()

Dim lastRow As Long
Dim thisRow As Long
Dim nextRow As Long
Dim foundCol As Variant
Dim nextCol As Long
Dim lastString As String

Dim dataSheet As Worksheet
Dim tranSheet As Worksheet

Set dataSheet = Worksheets("Data")
Set tranSheet = Worksheets.Add(After:=dataSheet)
tranSheet.Name = "Transposed"

lastRow = dataSheet.Cells(dataSheet.Rows.Count, "B").End(xlUp).Row
nextRow = 1
nextCol = 5
tranSheet.Range("1:1").Font.Bold = True
tranSheet.Range("C1").Value = dataSheet.Range("D3").Value
lastString = ""

For thisRow = 3 To lastRow
    foundCol = Application.Match(dataSheet.Cells(thisRow, "D").Value, tranSheet.Range("1:1"), 0)
    If IsError(foundCol) Then
        foundCol = nextCol
        tranSheet.Cells(1, foundCol).Value = dataSheet.Cells(thisRow, "D").Value
        nextCol = nextCol + 1
    End If
    If dataSheet.Cells(thisRow, "C").Value <> lastString Then
        lastString = dataSheet.Cells(thisRow, "C").Value
        nextRow = nextRow + 1
    End If
    tranSheet.Cells(nextRow, foundCol).Value = dataSheet.Cells(thisRow, "B").Value
    tranSheet.Cells(nextRow, "D").Value = dataSheet.Cells(thisRow, "C").Value
Next thisRow

tranSheet.Range(tranSheet.Columns(3), tranSheet.Columns(nextCol)).EntireColumn.AutoFit

End Sub

Also to create in a existing userdefined "Expected" worksheet properly formatted adjusted width rather than creating result in a New worksheet.
Hoping a positive response.