How do I search for a string using Line Input and then print the next 5 lines in Excel cell
Question
How do I search for a string, then when the string is found, write the entire line where the string is found, and then the next five lines into the same Cell in Excel using VBA?
Basically, I have a text file that I am importing into Excel using VBA. Based on a string, data from the file goes into cells under the appropriate column heading. The problem I am having is that some of my data is cut off at a line break. Due to the limitation of Line Input
.
This condition does not happen for all values, just the ones with line breaks like this one:
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
I'm trying to get everything from How to Fix:...
to Value:...
to write to my Excel sheet, in the same Cell along with the data on the How to fix:...
line.
I know that Input Line
automatically stops at line breaks and moves on to the next line. Which, w/o the my loop
attempts, is what the code below does.
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
I also tried using a FileSystemObject
but it doesn't print anything to the Excel worksheet. The code is below:
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
Solution
This code
- uses a
RegExp
to remove the linebreaks (replaced with a|
) to flatten then string - then extracts each match with a second
RegExp
change your filepath here c:\temo\test.txt
sample input and output at bottom
code
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
input
test 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 otherstuff
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: SomeValue2
Related Links: Some URL2
output
OTHER TIPS
Here's the full code
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
This works for me...
first, assign the text in the text file to a variable (my_var in the example below)
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
You can also clean up my_txt using the "replace" function if you like.