VBAによるデータ加工

下の画像のようにデータを加工するVBAを書いてみました。

もっと、簡単に書けるはずなので、もう少し考えてみようと思います。
VBAに詳しい方がいましたら、良い方法を教えて頂けると嬉しいです。

【加工前のデータ】

【加工後のデータ】

【データ加工の目的】
「誰が」「どの電話番号」「どこの場所」で使用しているのか表したデータから「どの電話番号」が「どこの場所」で使用されているのかがわかる一覧表を作る

【サンプルコード】

Sub サンプル()
'
' サンプル Macro
'
    Dim TelNumarr As Variant
    Dim ArrNum As Integer
    Dim Locarr As Variant
    Dim Loc As Variant
    Dim Num As Integer

    ActiveSheet.Range("$A$1", Range("$B$1").End(xlDown)).Select
    ActiveSheet.Range("$A$1", Range("$B$1").End(xlDown)).RemoveDuplicates Columns:=Array(1, 2), _
        Header:=xlYes
    
    Columns("A:A").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Range("$A$1", Range("$A$1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
    Num = WorksheetFunction.CountA(Range("A:A")) - 1

    TelNumarr = WorksheetFunction.Transpose(Range("$A$2", Range("$A$2").End(xlDown)))
    
    For i = 1 To Num
        Sheets("Sheet1").Select
        ActiveSheet.Range("$A$1", Range("$B$1").End(xlDown)).AutoFilter Field:=1, Criteria1:= _
            TelNumarr(i)
        Range("$B$2", Range("$B$2").End(xlDown)).Select
        Selection.Copy
        Range("$E$1").Select
        ActiveSheet.Paste
        ActiveSheet.Range("$A$1", Range("$B$1").End(xlDown)).AutoFilter Field:=1
        Locarr = WorksheetFunction.Transpose(Range("$E$1", Range("$E$1").End(xlDown)))
        ArrNum = WorksheetFunction.CountA(Range("E:E"))
        If ArrNum = 1 Then
            Loc = Locarr(1)
            Sheets("Sheet2").Select
            Cells((i + 1), 2) = Loc
        ElseIf ArrNum = 2 Then
            Loc = Locarr(1) + "|" + Locarr(2)
            Sheets("Sheet2").Select
            Cells((i + 1), 2) = Loc
        Else
            Loc = Locarr(1)
            For l = 2 To ArrNum
                Loc = Loc + "|" + Locarr(l)
            Next
            Sheets("Sheet2").Select
            Cells((i + 1), 2) = Loc
        End If
        Erase Locarr
    Next
    Sheets("Sheet1").Select
    ActiveSheet.Range("$A$1", Range("$B$1").End(xlDown)).AutoFilter Field:=1
    Sheets("Sheet2").Select
    Columns("B:B").Select
    Selection.ColumnWidth = 35
    Sheets("Sheet1").Select
    Range("B1").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B1").Select
    ActiveSheet.Paste
    
    Range("$A$1", Range("$B$1").End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Rows("9:9").Select
    Selection.Delete Shift:=xlUp
    Range("B2:B8").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub