Developing.ru

Код: Выделить всё

Public Sub TelJoiner()
    Dim i As Long
    Dim iMax As Long
    Dim s As String
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("Исходник")
        iMax = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        s = vbNullString
        For i = iMax To 2 Step -1
           With .Cells(i, 1)
               If .Value = .Offset(-1, 0).Value Then
                   s = s & ";" & .Offset(0, 1).Value
                   .EntireRow.Delete
               ElseIf Len(s) > 0 Then
                   s = s & ";" & .Offset(0, 1).Value
                   If Left$(s, 1) = ";" Then s = Mid$(s, 2)
                   .Offset(0, 1).Value = s
                   s = vbNullString
               End If
            End With
        Next i
        With .Columns(2)
            .HorizontalAlignment = xlLeft
            .AutoFit
        End With
    End With
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Код: Выделить всё

Sub TelInStr()
    Dim i As Long, j As Long, a(), b() As String, x As New Collection
    Application.ScreenUpdating = False
    With Sheets("Исходник")
        a = .Range(.[A2], .Cells(Rows.Count, "B").End(xlUp)).Value
        ReDim b(1 To UBound(a, 1), 1 To 2): j = 0
        For i = 1 To UBound(a, 1)
            On Error Resume Next: x.Add a(i, 1), CStr(a(i, 1))
            If Err = 0 Then
                j = j + 1: b(j, 1) = a(i, 1): b(j, 2) = a(i, 2)
            Else: b(j, 2) = b(j, 2) & ", " & a(i, 2): On Error GoTo 0
            End If
        Next
        .Range(.[A2], .Cells(UBound(b, 1) + 1, UBound(b, 2))).Value = b: .Columns(2).AutoFit
    End With
End Sub