Sub saveMaxAndDate()
    Dim resWorksheet As Worksheet, objectsWorksheet As Worksheet, debitWorksheet As Worksheet
    Set resWorksheet = Worksheets("Sheet3")
    Set objectsWorksheet = Worksheets("Sheet2")
    Set debitWorksheet = Worksheets("Sheet1")

    Dim row As Integer, j As Integer
    Dim max As Double
    Dim maxDate As Date
    Dim maxObjects As String

    Dim commaPos As Integer, commaPosNext As Integer
    Dim startMutual As Boolean
    Dim mutualBeginDate As Date, mutualEndDate As Date

    For row = 2 To debitWorksheet.Range("C2").End(xlDown).row
        resWorksheet.Cells(row, 1) = debitWorksheet.Cells(row, 3)
        col = 2
        max = -1
        startMutual = False
        Do While Not IsEmpty(debitWorksheet.Cells(1, col + 2))
            If Not IsEmpty(debitWorksheet.Cells(row, col + 2)) And debitWorksheet.Cells(row, col + 2).Value > max Then
                max = debitWorksheet.Cells(row, col + 2).Value
                maxDate = debitWorksheet.Cells(1, col + 2).Value
                maxObjects = objectsWorksheet.Cells(row, col + 2).Value
            End If

            commaPos = InStr(objectsWorksheet.Cells(row, col + 2).Value, ",")
            commaPosNext = InStr(objectsWorksheet.Cells(row, col + 3).Value, ",")

            If startMutual Then
                    If IsEmpty(objectsWorksheet.Cells(row, col + 3)) Or commaPosNext = 0 Then
                        startMutual = False
                        mutualEndDate = objectsWorksheet.Cells(1, col + 2).Value
                        resWorksheet.Cells(row, 4) = mutualEndDate
                    End If
            End If

            If Not IsEmpty(objectsWorksheet.Cells(row, col + 2)) Then

                If Not startMutual And commaPos <> 0 And commaPosNext <> 0 Then
                    startMutual = True
                    mutualBeginDate = objectsWorksheet.Cells(1, col + 2).Value
                    resWorksheet.Cells(row, 2) = "Yes"
                    resWorksheet.Cells(row, 3) = mutualBeginDate
                End If
            End If

            col = col + 1
        Loop

        If max > 0 Then
            resWorksheet.Cells(row, 5) = max
            resWorksheet.Cells(row, 6) = maxDate
            resWorksheet.Cells(row, 7) = maxObjects
        End If

    Next row
End Sub