как вынести Case из цикла?!

[Lays]

Доброго вечеру Уважаемые форумчане...столкнулась с одной проблемкой....
вот кусочек кода, вобщем фишка в том, в цикле около 50 Case'ов, и мне кажется по этому массив переполняется.... процедура даже не запускается, пишет Expected Array... уже не знаю что придумать=((((

Помогите пожалуйста....в отдельный модуль если вынести тоже ничего не получается...та же ошибка

Sub splitting_lalala()
 Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim m As Integer
    Dim tmpArr()
    Dim flag As Boolean
    Dim tmpStr As String
    Dim Left As Single
    flag = False
    k = 0
    ReDim tmpArr(k)
    For i = 1 To ThisWorkbook.Sheets.Count
        ThisWorkbook.Sheets(i).Select
        Cells(1, 9).Value = "Расходы связанные с ПО"
        Cells(2, 9).Value = "РАсходы по сопровождению"
        Cells(3, 9).Value = "РАсходы по услугам"
        .
        . 
        .
        Cells(50, 9).Value = "прочие выплаты"

Columns(9).ColumnWidth = 100
        Columns(10).ColumnWidth = 25
        Columns(10).NumberFormat = "#,##0.00"
        For j = 1 To 50
            Cells(j, 10).Value = 0
        Next
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''разделение по счетам'''''''''''''''''''''''''''''''''''''''''''''''
        j = 1
    
    Dim tmpStrr As String
    Do While Cells(j, 1).Text <> ""
    tmpStrr = Left(Cells(j, 5).Value, 4)
    Select Case tmpStrr

'Расходы связанные с ПО
Case Is = "6304"
                If (Right(Cells(j, 5).Text, 3) = "001") Or (Right(Cells(j, 5).Text, 3) = "004") Then
                      Cells(1, 10).Value = Cells(1, 10).Value + Cells(i, 7).Value
                End If
                
            Case Is = "6406"
                'РАсходы по сопровождению
                If (Right(Cells(j, 5).Text, 3) = "018") Or (Right(Cells(j, 5).Text, 3) = "019") Or (Right(Cells(j, 5).Text, 3) = "020") Or (Right(Cells(j, 5).Text, 3) = "021") Then
                      Cells(2, 10).Value = Cells(2, 10).Value + Cells(i, 7).Value
                End If
                'РАсходы по услугам
                If (Right(Cells(j, 5).Text, 3) = "014") Or (Right(Cells(j, 5).Text, 3) = "017") Then
                    Cells(3, 10).Value = Cells(3, 10).Value + Cells(i, 7).Value
                End If
              .
              .
              .и так 50 штук их

For m = 0 To k
                       If Cells(j, 5).Text = tmpArr(m) Then
                           flag = True
                       End If
                   Next
                   If flag = False Then
                       tmpArr(k) = Cells(j, 5).Text
                       k = k + 1
                       ReDim Preserve tmpArr(k)
                   End If
                   flag = False
               Case Else
                    MsgBox "неизвестный счет :-(" + Chr(13) + Chr(13) + _
                       "хвост счета " + Cells(j, 5).Text, vbCritical, "ÀÕÒÓÍÃ"
                   Rows(j).Interior.ColorIndex = 3
        
           
        End Select
        j = j + 1
        Loop
        
        Next
        tmpStr = tmpArr(0)
        For m = 1 To UBound(tmpArr)
        tmpStr = tmpStr + ", " + tmpArr(m)
        Next
                
        
        End Sub

То есть чтобы допустим не перебирать все счета 6406001,6406002, 6406003 и так далее, задается группа счетов Case Is = "6406"

Вот...возможно криво объяснила, очень жду ваших комментариев=)))

[doober]

Если вы приложите файлик,я думаю код можно сократить раз в 5 минимум,убрать все Case.
И обязательно должен присутствовать список счетов .можно на другом листе.

[Lays]

Видите, список счетов будет постоянно менятся...это выгрузки из бюджета банковской системы, и по идее информация конфиденциальная(((....ну все кейсы однотипные, там только группы счетов указываются...

[doober]

Дайте мне образец вашего файла строк 20,замените номера счетов,данные.,но не меняйте общую картину.Мне надо видеть.что .откуда берется,и в каком столбце находится.
можете на мыло.данные в профиле.