Sub Report()
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim r2max As Long, R As Long, R2 As Long, CL As Long, I As Long
    Dim C As Range, TL, KY
    
    Application.ScreenUpdating = False
    Set Sh1 = Sheets("Data")
    Set Sh2 = Sheets("1")
    r2max = Sh2.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    Sh2.Range("2:" & r2max).ClearContents
    R = 35
    
    While Sh1.Cells(R, 1) <> ""
        KY = Sh1.Cells(R, 2)
        Set C = Sh2.Range("A:A").Find(KY, LookIn:=xlValues)
        
        If Not C Is Nothing Then
            R2 = C.Row
        Else
            R2 = r2max
            For I = 1 To 2
                Sh2.Cells(R2, I) = Sh1.Cells(R, I + 1)
            Next I
            Sh2.Cells(R2, 3) = Sh1.Cells(R, 12)
            Sh2.Cells(R2, 4) = Sh1.Cells(R, 13)
            r2max = r2max + 1
        End If
        
        CL = 5
        While Sh2.Cells(R2, CL) <> ""
            CL = CL + 2
        Wend
        
        Sh2.Cells(R2, CL) = Sh1.Cells(R, 20)
        Sh2.Cells(R2, CL + 1) = Sh1.Cells(R, 1)

        TL = Sh2.Cells(R2, 3)
        For I = 5 To 11 Step 2
            TL = TL - Sh2.Cells(R2, I)
        Next I
        
        Sh2.Cells(R2, 13) = TL
        If TL = 0 Then
            Rows(R2 & ":" & R2).Select
            Selection.ClearContents
            r2max = r2max - 1
        End If
        R = R + 1
    Wend
    Application.ScreenUpdating = True
End Sub