Sub VBA_Add_Formula_to_Transpose_Rows_to_Columns()
Dim SurcSht As Worksheet, TrgtSht As Worksheet
Dim Rng As Range, SrctRng As Range, condRng As Range
'Set SurcSht = ThisWorkbook.Worksheets("Sheet2") 'change as you need
'Set TrgtSht = ThisWorkbook.Worksheets("Sheet3") 'change as you need
' or use ActiveSheet
Set SurcSht = ThisWorkbook.ActiveSheet
Set TrgtSht = ThisWorkbook.ActiveSheet
Set SrctRng = SurcSht.Range("B1:B" & SurcSht.Cells(Rows.Count, "B").End(xlUp).Row)
Set condRng = SurcSht.Range("A1:A" & SurcSht.Cells(Rows.Count, "A").End(xlUp).Row)
If SurcSht.Name = TrgtSht.Name Then SurcSht.Activate
StrtCl = 4 ' Column D as you want
StrtRw = 1 ' Row 1 as you want
SrcFC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(1, 1).Address
SrcSC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(2, 1).Address
SrcBC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(2, 1).Resize(SrctRng.Rows.Count - 1, 1).Address
codtFC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(1, 1).Address
codtSC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(2, 1).Address
codtBC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(2, 1).Resize(condRng.Rows.Count - 1, 1).Address
TrgtSht.Cells.FormatConditions.Delete
arr = Array("Class Name", "ClassA", "ClassB", "ClassC", "ClassD")
For i = 1 To 5
With TrgtSht.Cells(StrtRw - 1 + i, StrtCl)
.Value = arr(i - 1)
For b = 7 To 10
With .Borders(b)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
Next
If i = 1 Then
.Interior.Color = RGB(85, 135, 53)
Else
.Interior.Color = RGB(200, 225, 180)
End If
If i = 1 Then
.Font.Color = RGB(255, 255, 255)
.Font.Bold = True
Else
.Font.Color = RGB(0, 0, 0)
End If
End With
Next
For Each Rng In SrctRng
Rw = StrtRw + Rng.Column - SrctRng.Column
Cl = StrtCl + Rng.Row - SrctRng.Row
With TrgtSht.Cells(Rw, Cl + 1)
CntCL = Cells(StrtRw, StrtCl + 1).Address & ":" & .Address(False, False)
.Value = "=IF(COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0," & SrcFC & "&COLUMNS(" & CntCL & "),"""")"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
For b = 7 To 10
With .FormatConditions(1).Borders
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
Next
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(155, 195, 230)
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With .Offset(1, 0).Resize(4, 1)
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
For b = 7 To 10
With .FormatConditions(1).Borders
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
Next
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(220, 235, 245)
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To 4
With .Offset(i, 0)
.Value = "=IFERROR(INDEX(" & SrcBC & ",AGGREGATE(15,6,(ROW(" & codtBC & ")-ROW(" & codtSC & ")+1)/(" & codtBC & "=" & Cells(StrtRw + i, StrtCl).Address & "),COLUMNS(" & CntCL & "))),"""")"
End With
Next
End With
Next
End Sub