Sub iSumma()
Dim List3 As Worksheet
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim iSumma As Double
Dim Nomer As Integer
  Set List3 = Worksheets("Лист3")
  iLR = List3.Cells(Rows.Count, 3).End(xlUp).Row + 1
  List3.Range("A2:C" & iLR).Clear
    'цикл по столбцу А Листа2
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  With Worksheets("Лист1")
    iSumma = 0
    Nomer = 1
      For i = 1 To iLastRow
        Set FoundCell = .Columns(3).Find(Cells(i, 1), , xlValues, xlWhole)
         If Not FoundCell Is Nothing Then
           iLR = List3.Cells(Rows.Count, 3).End(xlUp).Row + 1
         .Range("B" & FoundCell.Row & ":C" & FoundCell.Row).Copy List3.Cells(iLR, 2)
         List3.Cells(iLR, 1) = Nomer
         .Range("B" & FoundCell.Row + 2 & ":C" & FoundCell.Row + 2).Copy List3.Cells(iLR + 1, 2)
            iSumma = iSumma + .Range("C" & FoundCell.Row + 2)
            Nomer = Nomer + 1
         End If
      Next
         iLR = List3.Cells(Rows.Count, 3).End(xlUp).Row + 1
         List3.Cells(iLR + 1, 2) = "Всего:"
         List3.Cells(iLR + 1, 3) = iSumma
     End With
       List3.Activate
End Sub

Sub Tablica()
Dim i As Long
Dim iLastRow As Long
Dim FoundFruit As Range
Application.ScreenUpdating = False
   iLastRow = Cells(Rows.Count, "C").End(xlUp).Row - 3
With Worksheets("Лист2")
  For i = iLastRow To 2 Step -3
    Set FoundFruit = .Columns(1).Find(Cells(i, "C"), , xlValues, xlWhole)
    If Not FoundFruit Is Nothing Then
      Rows(i + 1).Delete
    Else
      Rows(i & ":" & i + 2).Delete
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub