Suppression de lignes dans un fichier .xml

Dim Lignes() As String, LignesCond() As String
Sub NettXML()
Dim FamMAT, AdrXML As String, AdrXMLTrait As String
Dim BoolIFROC As Boolean, BoolMAT As Boolean, BoolCons As Boolean
Dim LigXML As String, i As Long
Dim fs, f1, f2
    ReDim Lignes(1 To 1) 'Tableau des lignes XML à conserver
    ReDim LignesCond(1 To 1) 'Tableau des lignes XML à conserver sous condition
    FamMAT = Range("A1:A" & Range("A65536").End(xlUp).Row) 'Tableau des familles pour lesquelles le XML est supprimé
    AdrXML = "C:\temp\essai.xml" 'Adresse du fichier à traiter
    AdrXMLTrait = "C:\temp\essai2.xml" 'Adresse du fichier traité
    BoolIFROC = False
    BoolMAT = False
    BoolCons = False
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f1 = fs.OpenTextFile(AdrXML, 1, False, -2)
    Do Until f1.AtEndOfStream
        LigXML = f1.ReadLine
        If UCase(LigXML) = "<IFROC>" Then BoolIFROC = True
        If UCase(LigXML) = "</IFROC>" Then BoolIFROC = False
        If UCase(LigXML) Like "<MAT>*</MAT>" Then BoolMAT = True
        If Not BoolIFROC And Not BoolMAT Then
            If BoolCons Then
                Call AjoutCond
                If Lignes(1) <> "" Then ReDim Preserve Lignes(1 To UBound(Lignes) + 1)
                Lignes(UBound(Lignes)) = LigXML
            End If
            ReDim LignesCond(1 To 1)
            BoolCons = False
        ElseIf BoolIFROC And Not BoolMAT Then
            If LignesCond(1) <> "" Then ReDim Preserve LignesCond(1 To UBound(LignesCond) + 1)
            LignesCond(UBound(LignesCond)) = LigXML
        ElseIf BoolIFROC And BoolMAT Then
            If TabloExist(FamMAT, LigXML) Then
                BoolCons = False
            Else
                If LignesCond(1) <> "" Then ReDim Preserve LignesCond(1 To UBound(LignesCond) + 1)
                LignesCond(UBound(LignesCond)) = LigXML
                BoolCons = True
            End If
            BoolMAT = False
        End If
    Loop
    f1.Close
    Set f2 = fs.CreateTextFile(AdrXMLTrait, True)
    For i = LBound(Lignes) To UBound(Lignes)
        f2.WriteLine Lignes(i)
    Next i
    f2.Close
    Set f1 = Nothing
    Set f2 = Nothing
    Set fs = Nothing
End Sub
Sub AjoutCond()
Dim i As Long
    For i = LBound(LignesCond) To UBound(LignesCond)
        If Lignes(1) <> "" Then ReDim Preserve Lignes(1 To UBound(Lignes) + 1)
        Lignes(UBound(Lignes)) = LignesCond(i)
    Next i
End Sub
Function TabloExist(Tablo, Valo) As Boolean
Dim i As Long
    For i = LBound(Tablo) To UBound(Tablo)
        If Valo Like "*" & Tablo(i, 1) & "*" Then
            TabloExist = True
            Exit For
        End If
    Next i
End Function