Dim TextLine, NUM As String, TXT As String
Dim TXT1() As String
Dim i As Integer
TXT = ""
ReDim TXT1(0)
i = 0
Open "E:\1.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, TextLine
TXT1(i) = TextLine
i = i + 1
ReDim Preserve TXT1(i)
Loop
Close #1
TextLine = ""
Open "E:\2.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, TextLine
NUM = ""
For i = 1 To Len(TextLine)
If Asc(Mid(TextLine, i, 1)) > 47 And Asc(Mid(TextLine, i, 1)) < 58 Then
NUM = NUM & Mid(TextLine, i, 1)
End If
Next i
For i = 0 To UBound(TXT1) - 1
If InStr(TXT1(i), NUM) > 0 Then
TextLine = Replace(TextLine, NUM, Left(TXT1(i), 4))
End If
Next i
TXT = TXT & TextLine & vbCrLf
Loop
Close #1
Open "E:\3.txt" For Output As #1
Print #1, TXT
Close #1