Comment rechercher une chaîne à l'aide de la saisie de ligne, puis imprimer les 5 lignes suivantes dans une cellule Excel

Question

Comment rechercher une chaîne, puis lorsque la chaîne est trouvée, écrire la ligne entière où la chaîne se trouve, puis les cinq lignes suivantes dans la même cellule dans Excel à l'aide de VBA ?

Fondamentalement, j'ai un fichier texte que j'importe dans Excel à l'aide de VBA.Sur la base d'une chaîne, les données du fichier sont placées dans des cellules sous l'en-tête de colonne approprié.Le problème que je rencontre est que certaines de mes données sont coupées lors d'un saut de ligne.En raison de la limitation de Line Input.

Cette condition ne se produit pas pour toutes les valeurs, uniquement pour celles avec des sauts de ligne comme celui-ci :

    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

J'essaie de tout obtenir de How to Fix:... à Value:... écrire sur ma feuille Excel, dans la même cellule avec les données du How to fix:... doubler.

Je sais que Input Line s'arrête automatiquement aux sauts de ligne et passe à la ligne suivante.Qui, sans mon loop tentatives, c'est ce que fait le code ci-dessous.

 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

J'ai aussi essayé d'utiliser un FileSystemObject mais il n'imprime rien sur la feuille de calcul Excel.Le code est ci-dessous :

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

Ce code

• utilise un RegExp pour supprimer les sauts de ligne (remplacés par un |) pour aplatir puis enfiler
• puis extrait chaque correspondance avec une seconde RegExp

changez votre chemin de fichier ici c:\temo\test.txt

exemple d'entrée et de sortie en bas

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

saisir

Testez comment réparer:Pour supprimer cette fonctionnalité, définissez les paramètres de clé de registre suivants :
Ruche:HKEY_LOCAL_MACHINE
Chemin:Système\CurrentControlSet\Services...
Clé:Une clé
Taper:DWORD
Valeur:Une certaine valeur
Liens connexes:Certains Url autres
Comment réparer:Pour supprimer cette fonctionnalité, définissez les paramètres de clé de registre suivants :
Ruche:HKEY_LOCAL_MACHINE PATH:Système\CurrentControlSet\Services...
Clé:Une clé
Taper:DWORD
Valeur:Une Valeur2
Liens connexes:Une URL2

sortir

Answer 2

Voici le code complet

  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

Cela fonctionne pour moi...

tout d'abord, affectez le texte du fichier texte à une variable (my_var dans l'exemple ci-dessous)

  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

Vous pouvez également nettoyer my_txt en utilisant la fonction "remplacer" si vous le souhaitez.