Option Explicit

Sub TargetSub(FirstRow As Long, TarColmn As Long, ResultRange As Range)
'FirstRow - НОМЕР строки в которой есть объединяющий код (там цифирка в примере 1172860220
'TarColmn - НОМЕР столбца в которм объединяемые записи
'ResultRange - адрес верхней левой ячейки куда хотите вставить итоговые данные
Dim WS As Worksheet
Dim LastRow As Long
Dim myRange As Range
Set WS = ThisWorkbook.Worksheets("Лист4")
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set myRange = Range((Cells(FirstRow, TarColmn - 1).Address & ":" & Cells(LastRow, TarColmn).Address))
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim sKey As String
Dim sS As String: sS = ","
Dim aT As Variant
Dim lR As Long
aT = myRange
If aT(1, 1) = "" Then MsgBox "Исправьте параметры"
For lR = LBound(aT, 1) To UBound(aT, 1)
    If aT(lR, 2) <> "" Then
        If aT(lR, 1) <> "" Then sKey = aT(lR, 1)
        If Dict.exists(sKey) Then Dict.Item(sKey) = Dict.Item(sKey) & sS & CStr(aT(lR, 2)) Else Dict.Add sKey, CStr(aT(lR, 2))
    End If
Next lR
If Dict.Count = 0 Then Exit Sub
ReDim aT(1 To Dict.Count, 1 To 2)
For lR = LBound(Dict.keys) To UBound(Dict.keys)
    aT(lR + 1, 1) = Dict.keys()(lR)
    aT(lR + 1, 2) = Dict.items()(lR)
Next lR
Set myRange = ResultRange.Resize(UBound(aT, 1), UBound(aT, 2))
myRange.ClearContents
myRange.NumberFormat = "@"
myRange = aT
'Debug.Print myRange.Address
End Sub
Sub test()
' Для вашего примера в первом сообщении
Call TargetSub(2, 3, Cells(2, 6))
End Sub

With ThisWorkbook.Worksheets("Лист1")
  MyChart.SeriesCollection(1).XValues = .Range(.Cells(2, 1), .Cells(4000, 1))
  MyChart.SeriesCollection(1).Values = .Range(.Cells(2, 2), .Cells(4000, 2))
End With

Sub Receive_data_from_diag_to_new_sheet()Application.ScreenUpdating = FalseDim NumberOfRows As IntegerDim X As ObjectDim iCol As IntegerDim stRyad As StringDim stSheet As StringWith Worksheets("ChartData")    .Cells.ClearEnd WithiCol = 0With ActiveChartstSheet = .NameFor Each X In .SeriesCollection    stRyad = CStr(X.Name)    iCol = iCol + 1    NumberOfRows = UBound(X.Values)         With Worksheets("ChartData")            .Cells(1, iCol) = "X-" & stRyad            .Range(.Cells(2, iCol), .Cells(NumberOfRows + 1, iCol)) = Application.Transpose(X.XValues)            iCol = iCol + 1            .Cells(1, iCol) = "Y-" & stRyad            .Range(.Cells(2, iCol), .Cells(NumberOfRows + 1, iCol)) = Application.Transpose(X.Values)        End WithNext XEnd With…….End sub

    For a = 1 To UBound(WorkArray, 1)
    Application.StatusBar = "adding a line" & a & " of " & z
    DoEvents
    If WorkArray(a, 10) <> 0 Then
         CurrRow = CurrRow + 1
        For CurrCol = 1 To UBound(WorkArray, 2)
                ActiveCell.Offset(CurrRow - 1, CurrCol - 1).Value = WorkArray(a, CurrCol)
        Next
    End If
    Next