Help with function to organise some data

Hi Snowtoad,

Apologies, I have missed this one.
Here you go, assuming you have your data arranged in column A to C, use following quick code (though it needs little improvisation but still it will work):-

Sub Macro4()
Application.ScreenUpdating = False

    Cells(1, 1).Select
    Selection.CurrentRegion.Select
    
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "Sheet1!R1C1:R11C3").CreatePivotTable TableDestination:="", TableName:= _
        "PivotTable5", DefaultVersion:=xlPivotTableVersion10

    ActiveSheet.PivotTables("PivotTable5").AddFields RowFields:=Array("Site", _
        "Author-Year")
    ActiveSheet.PivotTables("PivotTable5").PivotFields("Site").Orientation = _
        xlDataField

    ActiveSheet.PivotTables("PivotTable5").PivotSelect "", xlDataAndLabel, True
    Selection.Cut
    Range("A1").End(xlToRight).Select
 
    ActiveCell.Offset(0, -3).Range("A1").Select
    ActiveSheet.Paste

    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveCell.Offset(1, 0).Select
    
While ActiveCell.Value <> ""
Selection.Offset(1, 1).Select
    If Selection.Offset(1, 0).Value = "" Then
    Selection.Copy
    Else
    Range(Selection, Selection.End(xlDown)).Copy
    End If
    Selection.Offset(0, -1).Select
    If Selection.Offset(1, 0).Value = "" Then
    Selection.End(xlDown).Select
    Else
    Selection.Offset(1, 0).Select
    End If
    
    Selection.End(xlToLeft).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ActiveCell.Select
    If Selection.Offset(0, 1).Value = "" Then
    
    Selection.End(xlToRight).Select
    Else
    Selection.End(xlToRight).Select
    Selection.End(xlToRight).Select
    End If
Wend

Range("a1").End(xlToRight).Select

ActiveCell.Offset(0, -1).Formula = "=IF(ISNUMBER(SEARCH(""total"",RC[1])),""n"",""y"")"
Selection.Offset(0, -1).Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, -1).Range("A1").Select
    Range(Selection, Selection.End(xlUp)).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown

While ActiveCell.Value <> ""
    If ActiveCell.Value = "y" Then
    ActiveCell.EntireRow.Delete
    Else
    ActiveCell.Offset(1, 0).Select
    End If
Wend
Selection.EntireColumn.Delete
Selection.Offset(-1, 1).Select
Selection.EntireColumn.Delete
Selection.CurrentRegion.Copy
Range("a1").End(xlToRight).Offset(0, 1).Select
Selection.PasteSpecial
Selection.End(xlDown).Select
Selection.EntireRow.Delete
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub

Let me know if you need further assistance. Thanks.

Regards,
DILIPandey

<click on below 'star' if this helps >