Option Explicit Option Compare Text Dim lngLastRow As Long Sub test() Dim strText As String, strLine As String, i As Integer Dim strFile As String lngLastRow = 0 With Application.FileDialog(msoFileDialogOpen) .Filters.Clear .Filters.Add "Файл с текстом для обработки", "*.txt" .Title = "Поиск слов, начинающихся и заканчивающихся на одну букву" If .Show = False Then Exit Sub strFile = .SelectedItems(1) End With With ThisWorkbook.Worksheets(1) Range(.Columns(1), .Columns(2)).Clear End With DoEvents Open strFile For Input As #1 Do Until EOF(1) Line Input #1, strLine strText = strText & " " & strLine 'Для обработки больших файлов частями по 3000 строк раскомментировать код ниже '----------------------------- ' i = i + 1 ' If i = 3000 Then ' prcWordsCount strText ' i = 0 ' strText = " " ' End If '----------------------------- Loop Close #1 prcWordsCount strText MsgBox "В файле искомых слов: " & lngLastRow End Sub Sub prcWordsCount(strInput As String) Dim astrWords() As String, astrSigns() As String * 1, i As Long, j As Long If Len(strInput) = 0 Then Exit Sub strInput = Replace(strInput, ".", " ") strInput = Replace(strInput, ",", " ") strInput = Replace(strInput, ":", " ") strInput = Replace(strInput, ";", " ") strInput = Replace(strInput, "!", " ") strInput = Replace(strInput, "?", " ") strInput = Replace(strInput, "—", " ") strInput = Replace(strInput, "-", " ") strInput = Replace(strInput, "+", " ") strInput = Replace(strInput, "<", " ") strInput = Replace(strInput, ">", " ") strInput = Replace(strInput, "%", " ") strInput = Replace(strInput, "#", " ") strInput = Replace(strInput, "«", " ") strInput = Replace(strInput, "»", " ") strInput = Replace(strInput, "(", " ") strInput = Replace(strInput, ")", " ") astrWords = Split(strInput, " ") With ThisWorkbook.Worksheets(1) For i = LBound(astrWords) To UBound(astrWords) astrWords(i) = Trim(astrWords(i)) If Len(astrWords(i)) > 1 Then If Asc(astrWords(i)) > 191 Then If Left(astrWords(i), 1) = Right(astrWords(i), 1) Then ReDim Preserve astrSigns(j) astrSigns(j) = Left(astrWords(i), 1) j = j + 1 .Cells(j + lngLastRow, 2) = astrWords(i) End If End If End If Next i j = lngLastRow + j For i = lngLastRow + 1 To j .Cells(i, 1) = UCase(astrSigns(i - lngLastRow - 1)) Next i End With lngLastRow = j End Sub |