Проверка на условие (математическое) и составление списка

[Maxx]

Вот:

Sub Spisokkk()
Dim i As Long, wb As Worksheet, sb As Worksheet
Application.ScreenUpdating = False
    Sheets("обороты").Activate
    endTable = Cells(1, Columns.Count).End(xlToLeft).Column 'теперь не зависим от длины таблицы
    'ThisWorkbook.Worksheets("список с оборотами").Range("B3:F65000").ClearContents
    Set wb = ThisWorkbook.Worksheets("обороты")
    Set sb = ThisWorkbook.Worksheets("список с оборотами")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If wb.Cells(i, endTable) <> 0 And wb.Cells(i, endTable - 1) <> 0 _
            And wb.Cells(i, endTable - 2) <> 0 And wb.Cells(i, endTable - 3) <> 0 _
            And wb.Cells(i, endTable - 4) <> 0 And wb.Cells(i, endTable - 5) <> 0 _
            Then
                'месячные изменения
                chM = wb.Cells(i, endTable) / wb.Cells(i, endTable - 1) - 1
                'квартальные изменения
                chQ = (wb.Cells(i, endTable) + wb.Cells(i, endTable - 1) + wb.Cells(i, endTable - 2)) / (wb.Cells(i, endTable - 3) + wb.Cells(i, endTable - 4) + wb.Cells(i, endTable - 5)) - 1
                
                sb.Activate
                Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2).Offset(1) = wb.Cells(i, 3)
                Cells(Cells(Rows.Count, 3).End(xlUp).Row, 3).Offset(1) = chM
                Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Offset(1) = chQ
        End If
    Next i
End Sub

[robbe]

То, что надо! Спасибо большое! Я добавила еще сортировку, и теперь совсем красота)

[Maxx]

замените

sb.Activate
Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2).Offset(1) = wb.Cells(i, 3)
Cells(Cells(Rows.Count, 3).End(xlUp).Row, 3).Offset(1) = chM
Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Offset(1) = chQ

на

If chM > 0 Then
    sb.Activate
    Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2).Offset(1) = wb.Cells(i, 3)
    Cells(Cells(Rows.Count, 3).End(xlUp).Row, 3).Offset(1) = chM
    Cells(Cells(Rows.Count, 4).End(xlUp).Row, 4).Offset(1) = chQ
End If

и тогда будут выводится вообще только те, где оборот за месяц вырос.

[robbe]

Заменила. У меня возникла еще небольшая проблема. Делаю сортировку по этим двум значениям возрастанию (мес и квартал), но сортируется только по одному значению. Может, я где-то что-то не так написала в макросе. Посмотрите пжлста.

 With sb.Range("A2:D10000")
        .Sort _
          Key1:=.Range("C1:C10000"), Order1:=xlAscending, _
          Key2:=.Range("D1:D10000"), Order2:=xlAscending, _
          Header:=xlGuess, Orientation:=xlTopToBottom
     'Next
    End With