Private Sub Command1_Click()
    Dim papka As String:    papka = "H:\"
    Dim file1 As String:    file1 = ""
    Dim file2 As String:    file2 = ""

    file1 = Dir(papka & "*.txt")
    Do While file1 <> ""
        file2 = Mid(file1, 1, 8) & ".txt"
        Delete_String papka & file1, papka & file2
        file1 = Dir
    Loop
End Sub
Private Sub Delete_String(ByVal file1 As String, ByVal file2 As String)
    On Error GoTo err1
    Dim myCol As New Collection
    Dim Buf As String, slovo
    Dim i As Long, copy_ As Byte
    
    Dim kod As Integer
    Dim stroka As String
    
    Open file1 For Input As #1
    Do While Not EOF(1)
        Line Input #1, Buf
        Buf = Replace(Buf, "'", "")         'удалить апостроф
        slovo = Split(LTrim("" & Buf), " ") 'разбить строку по словам через пробел
        If UBound(slovo) > 0 Then
            kod = Asc(Mid(slovo(0), 1, 1))
            If kod >= 48 And kod <= 57 Then 'если код, первого символа, цифра
                stroka = ""
                For i = 0 To UBound(slovo)
                    If slovo(i) <> "" Then  'собрать строку, без пробелов
                        stroka = stroka & slovo(i) & " "
                    End If
                Next
                myCol.Add stroka
            End If
        End If
    Loop
    Close #1
    
    Open file2 For Append As #1
            
    For i = 1 To myCol.Count
        Print #1, myCol(i)
    Next i
    
    Close #1
    

    Exit Sub
err1:
    MsgBox Err.Description