Option Explicit

Sub otbor()
    Dim arr, i&, ai&, bi&, ci&, b(), c(), poz&

    'отключаем обновление экрана - сэкономим миллисекунду, но не будет мигать
    Application.ScreenUpdating = False

    'данные в массив
    With Sheets( 2 )
        arr = .Range(.Range("A" & .Rows.Count).End(xlUp), .[D1]).Value
        'или так
        'arr = .Range(.[D1], .Range("A" & .Rows.Count).End(xlUp)).Value
        'или даже в данном случае так
        'arr = .[a1].CurrentRegion.Value
    End With

    'создаём пустые массивы, сразу с заголовком
    ReDim a( 1  To UBound(arr),  1  To  3 )
    a( 1 ,  1 ) = "ТЕКСТ": a( 1 ,  3 ) = "ЧИСЛО"
    b = a
    c = a

    'заголовок уже посчитаем
    ai =  1 
    bi =  1 
    ci =  1 

    'перебор массива
    For i =  1  To UBound(a)
        'отбор данных
        Select Case arr(i,  1 )
        Case  1 
            ai = ai +  1 
            a(ai,  1 ) = arr(i,  1 )
            a(ai,  2 ) = arr(i,  2 )
            a(ai,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        Case  2 
            bi = bi +  1 
            b(bi,  1 ) = arr(i,  1 )
            b(bi,  2 ) = arr(i,  2 )
            b(bi,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        Case  3 
            ci = ci +  1 
            c(ci,  1 ) = arr(i,  1 )
            c(ci,  2 ) = arr(i,  2 )
            c(ci,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        End Select
    Next

    'выгрузка и сразу рамки
    poz =  1 
    With Sheets( 1 )
        With .Cells(poz,  1 )
            .Resize(ai,  3 ).Value = a
            .Resize(ai,  3 ).Borders.Weight = xlThin
            .Resize( 1 ,  3 ).Borders.Weight = xlMedium
        End With
        poz = poz + ai +  2 

        With .Cells(poz,  1 )
            .Resize(bi,  3 ).Value = b
            .Resize(bi,  3 ).Borders.Weight = xlThin
            .Resize( 1 ,  3 ).Borders.Weight = xlMedium
        End With
        poz = poz + bi +  2 

        With .Cells(poz,  1 )
            .Resize(ci,  3 ).Value = c
            .Resize(ci,  3 ).Borders.Weight = xlThin
            .Resize( 1 ,  3 ).Borders.Weight = xlMedium
        End With
    End With
    
    'включаем обновление экрана
    Application.ScreenUpdating = True
End Sub

Dim arr()

    'перебор массива
    For i =  1  To UBound(a)
        'отбор данных
        Select Case arr(i,  1 )
        Case  1 
            ai = ai +  1 
            a(ai,  1 ) = arr(i,  2 )
            a(ai,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        Case  2 
            bi = bi +  1 
            b(bi,  1 ) = arr(i,  2 )
            b(bi,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        Case  3 
            ci = ci +  1 
            c(ci,  1 ) = arr(i,  2 )
            c(ci,  3 ) = IIf(Len(arr(i,  3 )), arr(i,  3 ), arr(i,  4 ))
        End Select
    Next

Option Explicit

Sub otbor()
    Dim arr(), i&, ai&, bi&, ci&, b(), c(), poz&
    Dim sa As Double, sb As Double

    'отключаем обновление экрана - сэкономим миллисекунду, но не будет мигать
    Application.ScreenUpdating = False

    'данные в массив
    With Sheets( 2 )
        arr = .Range(.Range("A" & .Rows.Count).End(xlUp), .[G1]).Value
    End With

    'создаём пустые массивы, сразу с заголовком
    ReDim a( 1  To UBound(arr),  1  To  4 )
    a( 1 ,  1 ) = "ТЕКСТ": a( 1 ,  4 ) = "ЧИСЛО"
    b = a
    ReDim c( 1  To UBound(arr),  1  To  2 )
    c( 1 ,  1 ) = "ТЕКСТ": c( 1 ,  2 ) = "НОМЕР"

    'заголовок уже посчитаем
    ai =  1 
    bi =  1 
    ci =  1 

    'перебор массива
    For i =  1  To UBound(a)
        'отбор данных
        Select Case arr(i,  1 )
        Case  2 
            ai = ai +  1 
            a(ai,  1 ) = arr(i,  4 )
            a(ai,  4 ) = arr(i,  7 )
            sa = sa + CDbl(arr(i,  7 ))
        Case  3 
            bi = bi +  1 
            b(bi,  1 ) = arr(i,  4 )
            b(bi,  4 ) = arr(i,  7 )
            sb = sb + CDbl(arr(i,  7 ))
        Case  1 
            ci = ci +  1 
            c(ci,  1 ) = arr(i,  4 )
            c(ci,  2 ) = arr(i,  3 )
        End Select
    Next

    'выгрузка и сразу рамки
    poz =  1 
    With Sheets( 1 )
        With .Cells(poz,  1 )
            .Resize(ai,  4 ).Value = a
            .Resize(ai,  4 ).Borders.Weight = xlThin
            .Resize( 1 ,  4 ).Borders.Weight = xlMedium
        End With
        poz = poz + ai
        .Cells(poz,  1 ) = "Итого:"
        .Cells(poz,  4 ) = sa
        poz = poz +  3 

        With .Cells(poz,  1 )
            .Resize(bi,  4 ).Value = b
            .Resize(bi,  4 ).Borders.Weight = xlThin
            .Resize( 1 ,  4 ).Borders.Weight = xlMedium
        End With
        poz = poz + bi
        .Cells(poz,  1 ) = "Итого:"
        .Cells(poz,  4 ) = sb
        poz = poz +  4 

        With .Cells(poz,  1 )
            .Resize(ci,  2 ).Value = c
            .Resize(ci,  2 ).Borders.Weight = xlThin
            .Resize( 1 ,  2 ).Borders.Weight = xlMedium
        End With
    End With

    'включаем обновление экрана
    Application.ScreenUpdating = True
End Sub

     'выгрузка
    With Sheets( 1 )
        With .Cells( 2 ,  1 ) 'тут промахнулся в приложении, там (1, 1) написано....
            .Resize(ai,  4 ).Value = a
        End With

        With .Cells( 23 ,  1 )
            .Resize(bi,  4 ).Value = b
        End With

        With .Cells( 45 ,  1 )
            .Resize(ci,  2 ).Value = c
        End With
    End With

    'выгрузка
    With Sheets( 1 )
        .Cells( 2 ,  1 ).Resize(ai,  4 ).Value = a
        .Cells( 23 ,  1 ).Resize(bi,  4 ).Value = b
        .Cells( 45 ,  1 ).Resize(ci,  2 ).Value = c
    End With

    'выгрузка
    With Sheets( 1 )
        .Cells( 2 ,  1 ).Resize(ai,  4 ).Value = a
        .Cells( 23 ,  1 ).Resize(bi,  4 ).Value = b
       If ci >  0  Then .Cells( 45 ,  1 ).Resize(ci,  2 ).Value = c
    End With

     'выгрузка
    With Sheets( 1 )
        .Cells( 2 ,  1 ).Resize(ai,  4 ).Value = a
        .Cells( 23 ,  1 ).Resize(bi,  4 ).Value = b
       If ci >  0  Then
       .Cells( 45 ,  1 ).Resize(ci,  2 ).Value = c
       Else
       Rows("43:62").Delete
       End If
    End With

    'выгрузка
    With Sheets( 1 )
        .Cells( 2 ,  1 ).Resize(ai,  4 ).Value = a
        .Cells( 23 ,  1 ).Resize(bi,  4 ).Value = b
       If ci >  0  Then .Cells( 45 ,  1 ).Resize(ci,  2 ).Value = c Else Rows("43:62").Delete
    End With

 
       If ci >  0  Then .Cells( 45 ,  1 ).Resize(ci,  2 ).Value = c Else .Rows("43:62").Delete

With Sheets( 1 )
If ai >  0  Then заполнение_массива Else .[first_t].EntireRow.Delete
If bi >  0  Then заполнение_массива Else .[second_t].EntireRow.Delete
If ci >  0  Then заполнение_массива Else .[third_t].EntireRow.Delete
End With