Public Sub boldFontTargets()
    Dim actSheet As Worksheet
    Dim startPos, endPos, countSymbol As Integer
    Dim flag, flagBold As Boolean
    Dim searchStr, newValue As String
        
    Set actSheet = ThisWorkbook.ActiveSheet
    flag = True
    endPos = 0
    startPos = 0
    flagBold = True
    searchStr = vbTab
    
    While flag
        If (startPos = 0) Then
            startPos = InStr(1, actSheet.Cells(5, 3), searchStr)
        End If
        endPos = InStr(startPos + 1, actSheet.Cells(5, 3), searchStr)
        
        If (endPos = 0) Then
            countSymbol = Len(actSheet.Cells(5, 3)) - startPos
        Else
            countSymbol = endPos - startPos
        End If
        
        If (IsNumeric(startPos) And IsNumeric(endPos) And startPos > 0 And endPos > 0) Then
            With actSheet.Cells(5, 3).Characters(startPos, countSymbol).Font
                .Bold = flagBold
            End With
            startPos = endPos
            flagBold = Not flagBold
        Else
            flag = False
        End If
    Wend
  
End Sub

Private Sub ChoiceCatalog()
    Dim oDir As FileDialog
    Dim DirCatalog, SaveFileName
    
    Set oDir = Application.FileDialog(msoFileDialogFolderPicker)
        With oDir
            .Title = "Выбрать каталог"
            .ButtonName = "выбрать каталог"
            .Filters.Clear
            .InitialView = msoFileDialogViewLargeIcons
            
            If oDir.Show = 0 Then Exit Sub
            DirCatalog = .SelectedItems(1)
            fMain.tbPath.Value = DirCatalog
        End With
    
End Sub

fMain.tbPath.Value = DirCatalog

Dim doubles = {1.5, 2, 9.9, 18}

myArr(1, 0, 5)= {1,2,3,4,5,6,7,8}

'объявляю массив
  Dim myArr()
'задаю размерность массива
  ReDim myArr(2, 9, 9)
'присваиваю значение элементу массива 1,0,5 - массив нужный
  myArr(1, 0, 5) = Array(1, 2, 3, 4, 5, 6, 7)

Public aoCmbBxes() As new clsmCmbBxes

Public Sub UpdateCmBxes()
  Dim sh_tmp As Worksheet
  Dim elem As OLEObject, cb As Object
  Dim nom&


  ReDim aoCmbBxes(1 To 1)
  nom = 1
  For Each sh_tmp In ThisWorkbook.Worksheets
    For Each elem In sh_tmp.OLEObjects
      Set cb = elem.Object
      If TypeName(cb) = "ComboBox" Then
        ReDim Preserve aoCmbBxes(1 To nom)
        Set aoCmbBxes(UBound(aoCmbBxes)).oCmbBx = elem.Object
        nom = nom + 1
      End If
    Next elem
  Next sh_tmp
End Sub

  sName = "tut moye nazvanie"
  nom = UBound(aoCmbBxes) + 1
  ReDim Preserve aoCmbBxes(1 To nom)
  
  Set obj = sh_now.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
      DisplayAsIcon:=False, Left:=lCB, Top:=tCB, Width:=wCB, _
      Height:=hCB)
  obj.Name = sName
  Set aoCmbBxes(UBound(aoCmbBxes)).oCmbBx = obj
  
  Call UpdateCmBxes

Option Explicit
Public WithEvents oCmbBx As MSForms.ComboBox


Private Sub oCmbBx_Change()
      'delau 4to-to
End Sub

Set aoCmbBxes = New clsmCmbBxes

Set obj = sh_now.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
      DisplayAsIcon:=False, Left:=lCB, Top:=tCB, Width:=wCB, _
      Height:=hCB)
obj.Name = sName

aoCmbBxes.oCmbBx = obj

Public aoCmbBxes As clsmCmbBxes
Public clCmBxes As New Collection

For Each sh_tmp In ThisWorkbook.Worksheets
  For Each elem In sh_tmp.OLEObjects
    Set cb = elem.Object
    If TypeName(cb) = "ComboBox" Then
      Set aoCmbBxes = New clsmCmbBxes
      Set aoCmbBxes.oCmbBx = cb
      clCmBxes.Add aoCmbBxes
    End If
  Next elem

Next sh_tmp

Set aoCmbBxes = New clsmCmbBxes
Set aoCmbBxes.oCmbBx = list.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
      DisplayAsIcon:=False, Left:=lCB, Top:=tCB, Width:=wCB, _
      Height:=hCB).Name = sName

list.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, _
      DisplayAsIcon:=False, Left:=lCB, Top:=tCB, Width:=wCB, _
      Height:=hCB).Name = sName

Call UpdateCB