Неправильные результаты со словарем VBA

Вал функция может не возвращать правильное значение. Если ваши значения в столбце F Val(f.Range("F" & i)) на самом деле не являются целыми числами, их десятичные дроби могут быть обрезаны!

В документации говорится

The Val function stops reading the string at the first character that it can't recognize as part of a number.

The Val function recognizes only the period ( . ) as a valid decimal separator. When different decimal separators are used, as in international applications, use CDbl instead to convert a string to a number.

Поэтому, если в вашем номере есть какой-либо символ, он будет обрезан. В вашем случае , считается символом, и поэтому ваши значения превращаются в целые числа, поскольку , не рассматривается как десятичный разделитель.

Вместо этого обязательно используйте Функции преобразования типов:

cDbl(f.Range("F" & i))

преобразует значение в число с плавающей запятой с двойной точностью.

Уникализируйте данные с помощью словаря

• Если значение в первом уникальном столбце (в данном случае столбец 2) является значением ошибки или пустым,
  запись не будет включена.
• Если значение в других уникальных столбцах (в данном случае только в столбце 1) является значением ошибки,
  он будет преобразован в Empty (неявно).
• Если значение в столбце «Значение» (в данном случае столбец 3) не является числом,
  Вместо этого будет использоваться 0 (ноль).
• Настройте (поиграйте) значения в разделе констант.

Option Explicit

Sub UniquifyData()
    
    ' Source
    Const sName As String = "Feuil1"
    Const sFirstCellAddress As String = "A1"
    Dim uCols As Variant: uCols = VBA.Array(2, 1)
    Const svCol As Long = 3
    ' Destination
    Const dName As String = "Feuil1"
    Const dFirstCellAddress As String = "E1"
    ' Both
    Const Delimiter As String = "@"
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source range and write its values to the source array.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(sFirstCellAddress).CurrentRegion
    Dim Data As Variant: Data = srg.Value
    
    Dim srCount As Long: srCount = UBound(Data, 1)
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    ' Write the headers from the source array to the headers array.
    
    Dim cUpper As Long: cUpper = UBound(uCols)
    Dim Headers As Variant: ReDim Headers(1 To cUpper + 2)
    
    Dim c As Long
    
    For c = 0 To cUpper
        Headers(c + 1) = Data(1, uCols(c))
    Next c
    Headers(cCount) = Data(1, svCol)
    
    ' Write the unique values from the source array to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Variant
    Dim sString As String
    Dim r As Long
    
    For r = 2 To srCount
        For c = 0 To cUpper
            Key = Data(r, uCols(c))
            If c = 0 Then
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        sString = CStr(Key)
                    End If
                End If
                If Len(sString) = 0 Then Exit For
            Else
                If IsError(Key) Then Key = ""
                sString = sString & Delimiter & CStr(Key) ' join uniques
            End If
        Next c
        If Len(sString) > 0 Then
            If IsNumeric(Data(r, svCol)) Then
                dict(sString) = dict(sString) + Data(r, svCol)
            Else
                If Not dict.Exists(sString) Then dict(sString) = 0
            End If
            sString = ""
        End If
    Next r
    
    ' Define the destination array.
    
    Dim drCount As Long: drCount = dict.Count + 1
    
    ReDim Data(1 To drCount, 1 To cCount)
    
    ' Write the headers from the headers array to the destination array.
    
    For c = 1 To cCount
        Data(1, c) = Headers(c)
    Next c
    
    ' Write the values from the dictionary to the destination array.
    
    r = 1
    
    For Each Key In dict.Keys
        r = r + 1
        ' Write uniques.
        uCols = Split(Key, Delimiter) ' split uniques
        For c = 0 To cUpper
            Data(r, c + 1) = uCols(c)
        Next
        ' Write value.
        Data(r, cCount) = dict(Key)
    Next Key
    
    ' Write the values from the destination array to the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress).Resize(, cCount) ' reference first row
        ' Write data.
        .Resize(drCount).Value = Data
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
        ' Apply some formatting.
        '.Font.Bold = True ' headers
        '.EntireColumn.AutoFit ' columns
    End With
    
    ' Inform.
     
    MsgBox "Data uniquified.", vbInformation

End Sub