Excel - Reemplazar varios valores a la vez por otros asociados

<name>010001001</name>     <name>0100010010,246206295332404</name>

Sub Reemplazar_Codigo(Antes, Despues)

    CommandBars("Navigation").Visible = False

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = Antes

        .Replacement.Text = Despues

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Sub Reemplaza()

    Dim Orig As String, Dest As String, Fila As Integer, Ps As Long

    Open "C:\tmp\Docum_2.txt" For Binary As #1

    Open "C:\tmp\Docum_3.txt" For Output As #2

    Orig = Space(LOF(1))

    Get #1, , Orig

    Fila = 1

    While Cells(Fila, "A") <> ""

        Do

           Ps = InStr(Orig, Cells(Fila, "A"))

           If Ps > 0 Then

               Dest = Mid(Orig, 1, Ps - 1) + Cells(Fila, "B") + Mid(Orig, Ps + Len(Cells(Fila, "A")))

               Orig = Dest

           End If

        Loop While Ps > 0

        Fila = Fila + 1

    Wend

    Print #2, Orig;

    Close

End Sub