Sub SaveTxt()
MkDir "txt"
ChDir "txt"
Dim i As Integer
Application.ScreenUpdating = False
For i = 1 To Range("A65000").End(xlUp).Row
Workbooks.Add
Range("A1") = ThisWorkbook.Sheets("Sheet2").Cells(i, 1).Value
ActiveWorkbook.SaveAs Format(i, "000") & ".txt", xlUnicodeText
ActiveWorkbook.Close 0
Next i
Application.ScreenUpdating = True
End Sub