Sub tt()
    ar1 = Sheets("Лист2").Range("Наименования") 'таблицу Наименования - в массив
    Set slov1 = CreateObject("Scripting.Dictionary") 'это словарь1
    With slov1 'для него
        For j = 1 To UBound(ar1) 'цикл по массиву
            .Item(ar1(j, 2)) = ar1(j, 1) 'ключи = наименования, элементы = группы
        Next j
    End With
    ar2 = Sheets("Лист2").Range("Группы") 'таблицу Группы - в массив
    Set slov2 = CreateObject("Scripting.Dictionary") 'это словарь2
    With slov2
        For j = 1 To UBound(ar2) '
            .Item(ar2(j, 1)) = j 'ключи = группы, элементы = счёт по порядку
        Next j
    End With
    ar0 = Sheets("Лист1").Range("Главная[[Наименование]:[Остаток]]") 'таблицу Главная (столбцы от Наименование до Остаток) - в массив
    ReDim arit(1 To UBound(ar0), 1 To 3) 'пустой массив 3 столбца и столько строк, сколько в ar0
    Set slov0 = CreateObject("Scripting.Dictionary") 'это словарь 0
    With slov0 '
        For i = 1 To UBound(ar0) 'цикл по массиву
            If Not .exists(ar0(i, 1)) Then 'если в словаре slov0 еще нет ключа ar0(i,1) то
                For k = 9 To 12 'цикл по столбцам 9-12
                    If ar0(i, k) > 0 Then 'если там значение >0, то
                        aaaa = .Item(ar0(i, 1)) 'суем наименование в slov0
                        n_ = n_ + 1 'увеличиваем счетчик на 1
                        arit(n_, 3) = ar0(i, 1) 'в массиве arit третий столбец - наименование
                        arit(n_, 2) = slov1.Item(ar0(i, 1)) 'второй столбец - группа из slov1
                        arit(n_, 1) = slov2.Item(arit(n_, 2)) 'первый - порядковый номер группы изи slov2
                        Exit For 'если что-то нашли в If-е, то дальше проверять смысла нет, выход из цикла
                    End If
                Next k
            End If
        Next i
    End With
    Application.ScreenUpdating = 0 'откл обновления экрана
    Application.Calculation = xlCalculationManual 'и пересчета формул
    With Sheets("Лист3") 'для листа 3
        r0_ = 3 'первая строка
        r1_ = .Cells(.Rows.Count, 2).End(3).Row 'последняя заполненная строка в столбце 2
        If r1_ >= r0_ Then 'если r1>=r0, то
            .Cells(r0_, 1).Resize(r1_ - r0_ + 1, 3).ClearContents 'стираем первые 3 столбца со строки r0 и вниз
        End If
        .Range("A3").Resize(n_, 3) = arit 'вставляем туда полученный массив arit
        .Sort.SortFields.Clear 'дальше сортировка
        .Sort.SortFields.Add Key:=Range("A" & r0_).Resize(n_) 'сначала по столбу А
        .Sort.SortFields.Add Key:=Range("C" & r0_).Resize(n_) 'затем по столбцу С
        .Sort.SetRange Range("A" & r0_).Resize(n_, 3)
        .Sort.Apply
        .Columns(1).Clear 'стираем столбец А
        .Select 'выделяем лист
        Application.Goto Reference:=.Range("A1"), scroll:=True 'перепрыгиваем на ячейку А1
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub

Sub tt()
    ar1 = Sheets("Лист2").Range("Наименования") 'таблицу Наименования - в массив
    Set slov1 = CreateObject("Scripting.Dictionary") 'это словарь1
    With slov1 'для него
        For j = 1 To UBound(ar1) 'цикл по массиву
            .Item(ar1(j, 2)) = ar1(j, 1) 'ключи = наименования, элементы = группы
        Next j
    End With
    ar2 = Sheets("Лист2").Range("Группы") 'таблицу Группы - в массив
    Set slov2 = CreateObject("Scripting.Dictionary") 'это словарь2
    With slov2
        For j = 1 To UBound(ar2) '
            .Item(ar2(j, 1)) = j 'ключи = группы, элементы = счёт по порядку
        Next j
    End With
'    ar0 = Sheets("Лист1").Range("Главная[[Дата]:[Остаток]]") 'таблицу Главная (столбцы от Наименование до Остаток) - в массив
    ar0 = Sheets("Лист1").Range("Главная[[Наименование]:[Остаток]]") 'таблицу Главная (столбцы от Наименование до Остаток) - в массив
    ReDim arit(1 To UBound(ar0), 1 To 3) 'пустой массив 3 столбца и столько строк, сколько в ar0
    Set slov0 = CreateObject("Scripting.Dictionary") 'это словарь 0
    With slov0 '
        For i = 1 To UBound(ar0) 'цикл по массиву
            If Not .exists(ar0(i, 1)) Then 'если в словаре slov0 еще нет ключа ar0(i,1) то
'            If Not .exists(ar0(i, 2)) Then 'если в словаре slov0 еще нет ключа ar0(i,1) то
                For k = 9 To 12 'цикл по столбцам 9-12
'                    If ar0(i, 1) >= Sheets("Лист3").Range("F1") And ar0(i, 1) <= Sheets("Лист3").Range("F2") Then
                        If ar0(i, k) > 0 Then 'если там значение >0, то
                            aaaa = .Item(ar0(i, 1)) 'суем наименование в slov0
                            n_ = n_ + 1 'увеличиваем счетчик на 1
                            arit(n_, 3) = ar0(i, 1) 'в массиве arit третий столбец - наименование
                            arit(n_, 2) = slov1.Item(ar0(i, 1)) 'второй столбец - группа из slov1
                            arit(n_, 1) = slov2.Item(arit(n_, 2)) 'первый - порядковый номер группы изи slov2
                            Exit For 'если что-то нашли в If-е, то дальше проверять смысла нет, выход из цикла
                        End If
'                    End If
                Next k
            End If
        Next i
    End With
    Application.ScreenUpdating = 0 'откл обновления экрана
    Application.Calculation = xlCalculationManual 'и пересчета формул
    With Sheets("Лист3") 'для листа 3
        r0_ = 3 'первая строка
        r1_ = .Cells(.Rows.Count, 2).End(3).Row 'последняя заполненная строка в столбце 2
        If r1_ >= r0_ Then 'если r1>=r0, то
            .Cells(r0_, 1).Resize(r1_ - r0_ + 1, 3).ClearContents 'стираем первые 3 столбца со строки r0 и вниз
        End If
        .Range("A3").Resize(n_, 3) = arit 'вставляем туда полученный массив arit
        .Sort.SortFields.Clear 'дальше сортировка
        .Sort.SortFields.Add Key:=Range("A" & r0_).Resize(n_) 'сначала по столбу А
        .Sort.SortFields.Add Key:=Range("C" & r0_).Resize(n_) 'затем по столбцу С
        .Sort.SetRange Range("A" & r0_).Resize(n_, 3)
        .Sort.Apply
        .Columns(1).Clear 'стираем столбец А
        .Select 'выделяем лист
        Application.Goto Reference:=.Range("A1"), scroll:=True 'перепрыгиваем на ячейку А1
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = 1
End Sub