Как мне выполнить поиск строки с помощью строчного ввода, а затем распечатать следующие 5 строк в ячейке Excel

Question

Как мне выполнить поиск строки, затем, когда строка найдена, записать всю строку, в которой найдена строка, а затем следующие пять строк в ту же ячейку в Excel с использованием VBA?

По сути, у меня есть текстовый файл, который я импортирую в Excel с помощью VBA.Основываясь на строке, данные из файла помещаются в ячейки под соответствующим заголовком столбца.Проблема, с которой я сталкиваюсь, заключается в том, что некоторые из моих данных обрываются при разрыве строки.В связи с ограничением Line Input.

Это условие выполняется не для всех значений, а только для тех, у которых есть разрывы строк, подобные этому:

    How To Fix: To remove this functionality, set the following Registry key settings:
    Hive: HKEY_LOCAL_MACHINE
    Path: System\CurrentControlSet\Services...
    Key: SomeKey
    Type: DWORD
    Value: SomeValue
    Related Links: Some URL

Я пытаюсь получить все от How to Fix:... Для Value:... для записи в мой лист Excel, в ту же ячейку вместе с данными на How to fix:... линия.

Я знаю это Input Line автоматически останавливается при разрыве строки и переходит к следующей строке.Который, без моего loop попытки - это то, что делает приведенный ниже код.

 If InStr(inputline, "How to Fix:") <> 0 Then
    'Do While Not InStr(inputline, "Related Links:")
    ' Get rid of special characters in string
       For i = 1 To Len(description)
            sletter = Mid(description, i, i + 1)
            iasc = Asc(sletter)
           If Not (iasc <= 153 And iasc >= 32) Then
                  description = Left(description, i - 1) & " " & Right(description, Len(description) - i)
           ' End If

       'Next
       Do Until InStr(inputline, "Related Links:") = 1
            description = Replace(description, "How to Fix:", "")
            ws.Cells(rowndx4, 7).Value = Trim(description)
        Loop
End If

Я также пробовал использовать FileSystemObject но он ничего не печатает на листе Excel.Код приведен ниже:

Private Function ScanFile2$(FileToRead2 As String, rowndx4 As Long)

Dim wb As Workbook, ws As Worksheet, i As Long
Dim FNum3 As Integer, inputline As String, whatfile As Integer, testnum As String
Dim description As String
Dim finding As String

Set ws = ActiveWorkbook.Worksheets("Sheet1")
    FNum3 = FreeFile()

Dim oFSO As FileSystemObject
Set oFSO = New FileSystemObject
Dim TS As TextStream
Const ForReading = 1
Set TS = oFSO.OpenTextFile(FNum3, ForReading)

Do While TS.AtEndOfStream <> True
inputline = TS.ReadAll
description = inputline

If InStr(inputline, "How To Fix:") <> 0 Then
            description = Replace(inputline, "How To Fix:", "")
            ws.Cells(rowndx4, 2).Value = inputline
End If
Exit Do
Loop
Close FNum3
Set ws = Nothing        
Application.ScreenUpdating = True
ScanFile2 = rowndx4
End Function

Answer 1

Этот код

• использует RegExp чтобы удалить разрывы строк (заменены на |) расплющить, затем натянуть
• затем извлекает каждое совпадение со вторым RegExp

измените свой путь к файлу здесь c:\temo\test.txt

пример ввода и вывода внизу

код

Sub GetText()

Dim objFSO As Object
Dim objTF As Object
Dim objRegex As Object
Dim objRegMC As Object
Dim objRegM As Object
Dim strIn As String
Dim strOut As String
Dim lngCnt As Long

Set objRegex = CreateObject("vbscript.regexp")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objts = objFSO.OpenTextFile("c:\temp\test.txt")

strIn = objts.readall

With objRegex
.Pattern = "\r\n"
.Global = True
.ignorecase = True
strOut = .Replace(strIn, "|")
.Pattern = "(How to Fix.+?)Related"
Set objRegMC = .Execute(strOut)
For Each objRegM In objRegMC
lngCnt = lngCnt + 1
Cells(lngCnt, 7) = Replace(objRegM.submatches(0), "|", Chr(10))
Next
End With

End Sub

входные данные

тест Как исправить:Чтобы удалить эту функцию, установите следующие параметры раздела реестра:
Улей:HKEY_LOCAL_MACHINE: HKEY_LOCAL_MACHINE
Путь:System\CurrentControlSet\Службы...
Клавиша:Какой - то странный
Тип:DWORD
Значение:Некоторая ценность
Ссылки по теме:Какой-нибудь URL другой материал
Как это исправить:Чтобы удалить эту функцию, установите следующие параметры раздела реестра:
Улей:HKEY_LOCAL_MACHINE Путь:System\CurrentControlSet\Службы...
Клавиша:Какой - то странный
Тип:DWORD
Значение:Некоторое значение2
Ссылки по теме:Какой- нибудь URL2

выходной сигнал

Answer 2

Вот полный код

  Sub test()
  ' Open the text file
    Workbooks.OpenText Filename:="C:\Excel\test.txt"

  ' Select the range to copy and copy
    Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy

  ' Assign the text to a variable
    Set my_object = CreateObject("htmlfile")
    my_var = my_object.ParentWindow.ClipboardData.GetData("text")
  ' MsgBox (my_var)   ' just used for testing
    Set my_object = Nothing

    pos_1 = InStr(1, my_var, "How to fix:", vbTextCompare)
    pos_2 = InStr(pos_1, my_var, "Related Links", vbTextCompare)
    my_txt = Mid(my_var, pos_1, -1 + pos_2 - pos_1)

  ' Return to the original file and paste the data
    Windows("stackoverflow.xls").Activate
    Range("A1") = my_txt

  ' Empty the clipboard
    Application.CutCopyMode = False
  End Sub

.

Это работает для меня ...

Первый, назначить текст в текстовом файле в переменной (my_var в примере ниже)

  pos_1 = InStr(1, my_var, "How to fix:", vbTextCompare)
  pos_2 = InStr(pos_1, my_var, "Related Links", vbTextCompare)
  my_txt = Mid(my_var, pos_1, -1 + pos_2 - pos_1)
  Range("wherever you want to put it") = my_txt

.

Вы также можете убирать my_txt, используя функцию «Заменить», если хотите.