Как в массив добавить внесение не только по 4 символам, но и по 2,3,5 и 7?

 For y = BaseStart.Row To BaseStart.End(xlDown).Row
     ArBase(n) = Left$(LTrim$(Sheets("Лист2").Cells(y, BaseStart.Column)), 4)
       'ArBase(n) = Left$(LTrim$(Sheets("Лист2").Cells(y, BaseStart.Column)), 3)
        n = n + 1
    Next y
 
ReDim Preserve ArList1(1 To 1)
      n = 0
      For y = CStart.Row To Sheets("Лист1").Cells(Rows.Count, x).End(xlUp).Row 'по всем кодам
        tmp = Trim$(Sheets("Лист1").Cells(y, x))
        tmp = Add_Ziro(tmp, 4) 'дописываем нули, если знаков < 7 (кол-во знаков = 4)
       ' tmp = Add_Ziro(tmp, 3)
        For nn = 1 To n 'ищем и записываем в массив уникальные коды
          If ArList1(nn) = tmp Then Exit For
        Next

Private Function Add_Ziro$(ByVal tmp$, Razr%) 'Razr - сколько должно получится
    If Len(tmp) > 2 Then 'защита от ошибок
          'берем первые 4 символа без пробела (лист1)
          'и дописываем вначало строки нули, если кол-во разрядов < 7
          tmp = String(7 - Len(tmp), "0") & Left$(tmp, Razr - (7 - Len(tmp))) '7 - кол-во разрядов, 4 - кол-во нужных симв.
          Else: tmp = Left$(tmp, 2) 'если разрядов <=2, берем абы что-нибуть
    End If
    Add_Ziro = tmp
End Function

 For y = BaseStart.Row To BaseStart.End(xlDown).Row
     ArBase(n) = Left$(LTrim$(Sheets("Лист2").Cells(y, BaseStart.Column)), 4)
       'ArBase(n) = Left$(LTrim$(Sheets("Лист2").Cells(y, BaseStart.Column)), 3)
        n = n + 1
    Next y

ReDim ArBase(1 To Range(BaseStart, BaseStart.End(xlDown)).Cells.Count)
    ReDim Exclude(1 To 1)
    
    '=== сгружаем в массив все ОКДП в базе ===
    For y = BaseStart.Row To BaseStart.End(xlDown).Row
        ArBase(n) = Left$(LTrim$(Sheets("Лист2").Cells(y, BaseStart.Column)), 2)
        n = n + 1
    Next y
    
    '=== по всем фирмам ===
    For x = 1 To CStart.Offset(-1).End(xlToRight).Column Step 2 'кол-во фирм = кол-во столбцов /2
      Sheets("Лист4").Cells(yDest, 1) = "Фирма" & x \ 2 + 1 'шапка
      Sheets("Лист4").Cells(yDest, 2) = Sheets("Лист1").Cells(CStart.Row, x).Offset(-4, 1) 'Firm
      Sheets("Лист4").Cells(yDest, 3) = "почта"
      Sheets("Лист4").Cells(yDest, 4) = Sheets("Лист1").Cells(CStart.Row, x).Offset(-2, 1) 'Mail
      Sheets("Лист4").Cells(yDest + 1, 1) = "Доброго дня, " & Sheets("Лист1").Cells(CStart.Row, x).Offset(-3, 1) & "!" 'Face
      
      '=== запись уникальных входящих ОКДП-групп в массив ===
      ReDim Preserve ArList1(1 To 1)
      n = 0
      For y = CStart.Row To Sheets("Лист1").Cells(Rows.Count, x).End(xlUp).Row 'по всем окдп
        tmp = Trim$(Sheets("Лист1").Cells(y, x))
        tmp = Add_Ziro(tmp, 2) 'дописываем нули, если знаков < 7 (кол-во знаков = 4)
        For nn = 1 To n 'ищем и записываем в массив уникальные окдп
          If ArList1(nn) = tmp Then Exit For
        Next
        If nn = n + 1 Then n = n + 1: ReDim Preserve ArList1(1 To n): ArList1(n) = tmp
      Next y
      
      '=== запись исключений ОКДП в массив
      ReDim Preserve Exclude(1 To 1)
      n = 9 'номер строки, где начинаются исключения
      Do While Len(Sheets("Лист1").Cells(n, x + 1)) <> 0
        If Exclude(UBound(Exclude)) <> vbNullString Then ReDim Preserve Exclude(1 To UBound(Exclude) + 1)
        tmp = Trim(Sheets("Лист1").Cells(n, x + 1))
        tmp = Add_Ziro(tmp, 7) 'дописываем нули, если знаков < 7 (кол-во знаков = 7)
        Exclude(UBound(Exclude)) = tmp
        n = n + 1
      Loop
    
      '=== сравнение массивов ОКДП, в т.ч. исключения ===
      For nn = 1 To UBound(ArList1)
        For n = 1 To UBound(ArBase) 'по всем окдп базы (из массива)
          If ArBase(n) = ArList1(nn) Then 'сравниваем окдп двух массивов (входящие и базу)
            'проверка на исключения
            For nEx = 1 To UBound(Exclude)
              If InStr(Sheets("Лист2").Cells(n, 6), Exclude(nEx)) Then Exit For
            Next nEx
            If nEx = UBound(Exclude) + 1 Then 'если не было исключений
              If Success = False Then 'если не было ни одной записи
                Success = True
                Sheets("Лист4").Cells(yDest + 2, 1) = Ex 'дописываем шапку
                yDest = yDest + 3 'через 3 строки
              End If
              Range(Sheets("Лист2").Cells(n, 1), Sheets("Лист2").Cells(n, 10)).Copy Sheets("Лист4").Range("A" & yDest)
              yDest = yDest + 1 'через 1 строку
            End If
          End If
        Next n
      Next nn