Set dic = CreateObject("Scripting.Dictionary")
Set dicCopy = CreateObject("Scripting.Dictionary")

dicCopy=dic

Private Sub UserForm_Initialize()
Dim lr As Long, arr As Variant
With ActiveSheet
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row
    arr = .Range("A1:B" & lr)
End With
With ListBox1
    .ColumnCount = 2
    .ColumnWidths = "50;5"
    .List = arr
End With
End Sub

Function extract(what As Range) As String
    With CreateObject("VBScript.Regexp")
        .Pattern = "[0-9.]+\, ?[0-9.]+$"
        .Global = False
        .MultiLine = False
        .IgnoreCase = False
        
        If .test(what) Then extract = .Execute(what)(0): Exit Function
    End With
    extract = ""
End Function

Function split_and_extract(what As String)
Dim arr
arr = Split(what, ",")
split_and_extract = arr(UBound(arr) - 1) & "," & arr(UBound(arr))
End Function

pip install fitparse

from fitparse import FitFile
fitfile = FitFile('your_fit_file.fit') # открываем фалй .fit

Private Sub get_color(dict As Object)

Dim i As Long, arr As Variant
Dim color As Long, upperbound As Long, lowerbound As Long
Set dict = CreateObject("Scripting.Dictionary")
With ActiveSheet

    upperbound = 15983321 ' нижняя граница цвета
    lowerbound = 15970000 ' верхняя граница цвета
    
    arr = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    
    For i = 2 To UBound(arr, 1)
        If .Cells(i, 1).Interior.color = 16777215 Then
            If Not dict.exists(arr(i, 1)) Then
                color = Int((upperbound - lowerbound + 1) * Rnd + lowerbound) ' случайный цвет
            End If
        Else
            color = .Cells(i, 1).Interior.color
        End If
        
        If Not dict.exists(arr(i, 1)) Then
            dict.Add arr(i, 1), color
        Else
            dict(arr(i, 1)) = color
        End If
    Next i
    
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub

Static dict As Object
If dict Is Nothing Then Call get_color(dict)

Target.EntireRow.Interior.color = dict(Cells(Target.Row, 1).Value)

End Sub

Option Explicit
Private Sub get_color(dict As Object)

Dim i As Object, color As Long, upperbound As Long, lowerbound As Long
Set dict = CreateObject("Scripting.Dictionary")
With ActiveSheet

    upperbound = 15983321 ' нижняя граница цвета
    lowerbound = 15970000 ' верхняя граница цвета
    
    For Each i In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        If i.Interior.color = 16777215 Then
            If Not dict.exists(i.Value) Then
                color = Int((upperbound - lowerbound + 1) * Rnd + lowerbound) ' случайный цвет
            End If
        Else
            color = i.Interior.color
        End If
        
        If Not dict.exists(i.Value) Then
            dict.Add i.Value, color
        Else
            dict(i.Value) = color
        End If
    Next i
    
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Static dict As Object

If dict Is Nothing Then Call get_color(dict)
Target.EntireRow.Interior.color = dict(Cells(Target.Row, 1).Value)

End Sub

Function countWithRegEx(dataRange As Range, criteria As String) As String
Dim i As Range, totalSumm As Double
    totalSumm = 0
    With CreateObject("VBScript.Regexp")
        .Global = False
        .MultiLine = False
        .IgnoreCase = False
        .Pattern = "\d+\,?\d*"
        For Each i In dataRange
            If .test(i.Value) Then totalSumm = totalSumm + CDbl(.Execute(i.Value)(0))
        Next i
        
    End With
    countWithRegEx = CStr(totalSumm) & " " & criteria
End Function

Function regexExtract(cell As Range) As String
    With CreateObject("VBScript.Regexp")
        
        .Pattern = "[A-Z]{2}\-?[A-Z0-9]+"
        .Global = False
        .MultiLine = False
        .Ignorecase = False
        
        If .test(cell) Then regexExtract = .Execute(cell)(0): Exit Function
        
    End With
    
    regexExtract = "without matches"
End Function

Sub test()
        Dim s as string
        Dim arr
        Dim i as long
        With ActiveSheet
            arr = .cells(1,1).CurrentRegion
            for i = Lbound(arr, 1) to Ubound(arr, 1)
                .cells(i,2) = split(arr(i,1), "_")(1)
            next i
        End With
End Sub

.MultiLine = False

.MultiLine = True

(.*)\/\/

Function regex_execute(what, pattern) As String
'regex_execute -- функция для извлечения текста
'what - ячейка с исходным текстом
'pattern - паттерн - строка для регулярного выражения
With CreateObject("VBScript.Regexp")
    .Global = False
    .MultiLine = False
    .Ignorecase = True
    .pattern = pattern
    If .test(what) Then regex_execute = .Execute(what).Item(0).submatches.Item(0): Exit Function
End With
regex_execute = "нет совпадений"
End Function

A(i)= Application.InputBox("введите число:", type:=1)

exception_arr = Array("абрикос","картошка","огурцы","помидоры")