Code VBA pour rechercher une chaîne de caractères puis une deuxième chaîne et renvoyer les lignes de données d'un fichier texte

Question

J'essaie d'effectuer une recherche dans des fichiers journaux volumineux afin de trouver une chaîne de texte, puis, si cette chaîne est présente, de trouver une autre chaîne de texte et enfin de renvoyer les 5 lignes de données suivantes. J'ai réussi à rechercher la chaîne de caractères dans le fichier texte et à renvoyer les 5 lignes suivantes, mais je ne parviens pas à faire en sorte que la macro recherche les deux lignes de texte avant de renvoyer les 5 lignes.

Par exemple, si le fichier texte ressemble à ceci :

17:42:56: Log File Closed 17:42:56: PrintInvoice: 2 17:42:56: copyReportData: 17:42:56: getNextRptDataID: 17:42:58: CalcDelCharge: 17:42:58: Sub Total: 3.80 17:42:58: Del Total: 0.00 17:42:58: Disc Total: 0.00 17:42:58: Vat Total: 0.00 17:42:58: Inv Total: 3.80 18:33:00: CalculateAmtDue: 18:33:00: CalculateChange: 18:33:00: UpdateDelCharge: 18:33:00: UpdateTotals 18:42:58: CalcDelCharge: 18:42:58: Sub Total: 5.80 18:42:58: Del Total: 0.00 18:42:58: Disc Total: 0.00 18:42:58: Vat Total: 0.00 18:42:58: Inv Total: 5.80

Je veux extraire les 5 lignes après le premier "CalcDelCharge", car elles suivent "PrintInvoice : 2", qui est l'une des chaînes que je veux également rechercher.

Le fichier texte contient "CalcDelCharge" partout, mais je ne suis intéressé que par les cas où il vient après "PrintInvoice : 2", qui apparaît beaucoup moins souvent.

Voici ce que j'ai jusqu'à présent

Dim fn As String, txt As String, delim As String, a() As String
Dim i As Long, ii As Long, iii As Long, x, y
fn = "C:\Documents\tilllogfile.log"
delim = vbTab
temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
x = Split(temp, vbCrLf)
ReDim a(1 To UBound(x) + 1, 1 To 100)
For i = 0 To UBound(x)
    If InStr(1, x(i), "CalcDelCharge", 1) Then
    For ii = 0 To 5
        n = n + 1: y = Split(x(i + ii), delim)
        For iii = 0 To UBound(y)
            a(n, iii + 1) = y(iii)
        Next
    Next
End If

Cela va extraire 5 lignes après tous les 'CalcDelCharge' et les mettre dans une feuille de calcul pour moi, je n'ai pas été en mesure de le réduire aux instances où il suit 'PrintInvoice : 2'.

Toute aide serait grandement appréciée.

Merci.

Answer 1

Déclarez une variable booléenne pour indiquer à la macro si votre texte a été trouvé.

Dim boolFound As Boolean

dans votre boucle la plus externe, ajoutez le premier test :

For i = 0 To UBound(x)
    If InStr(1, x(i), "PrintInvoice: 2", 1) Then
        boolFound = True
    End If

dans votre deuxième condition d'ajout de test :

If InStr(1, x(i), "CalcDelCharge", 1) And boolFound Then

n'oubliez pas de changer boolFound en false après avoir copié vos cinq lignes :

    boolFound = False
End If

Answer 2

Voici ma version (sans booléens), qui utilise simplement des boucles imbriquées. Ici, nous plaçons les valeurs dans un tableau pour que vous puissiez faire ce que vous voulez avec :

Données de l'échantillon :

Option Explicit
Sub Test()
Dim searchvalue1 As String, searchvalue2 As String, myarray() As Variant, i As Long, j As Long, k As Long, l As Long

ReDim myarray(0 To 0)
searchvalue1 = "PrintInvoice: 2"
searchvalue2 = "CalcDelCharge:"
l = 1

For i = 1 To 100
    If InStr(Range("A" & i).Value, searchvalue1) > 0 Then
        For j = i + 1 To 100
            If InStr(Range("A" & j).Value, searchvalue2) > 0 Then
                For k = 0 To 4
                    ReDim Preserve myarray(UBound(myarray) + 1) As Variant
                    myarray(k) = Range("A" & j + l).Value
                    l = l + 1
                    Debug.Print myarray(k)
                Next k
            End If
        Next j
    End If
Next i

End Sub

Fenêtre immédiate :

Answer 3

Vous pouvez utiliser Regex J'ai dû utiliser deux Regex, mais cela pourrait être possible avec une seule.

Dim str1 As Variant, str2 As Variant
ReDim str1(0 To 100)
ReDim str2(0 To 100)
Dim objMatches As Object
Dim j As Long, k As Long
j = 0
k = 0
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
objRegExp.Pattern = "(?:PrintInvoice: 2)[\s\S]*?(?:\s*(?:\d+:)+\s*[\w\s]*:\s\d.*)+" 'https://regex101.com/r/ChRr4w/1/
objRegExp.Global = True
Set objMatches = objRegExp.Execute(temp)
If objMatches.Count <> 0 Then
    For Each m In objMatches
        str1(j) = m.Value
        j = j + 1
    Next
    ReDim Preserve str1(0 To j - 1)
    For j = LBound(str1) To UBound(str1)
    txt = txt & str1(j) & vbCrLf
    Next j
End If
objRegExp.Pattern = "(?:\d+:)+\s*([\w\s]*:\s\d.*)" 'https://regex101.com/r/CLAL9i/1/
Set objMatches = objRegExp.Execute(txt)
  If objMatches.Count <> 0 Then
    For Each m In objMatches
        str2(k) = m.Submatches(0)
        k = k + 1
    Next
    ReDim Preserve str2(0 To k - 1)
    For k = LBound(str2) To UBound(str2)
    result = result & str2(k) & vbCrLf
    Next k
End If
Debug.Print result

Résultat