Discussion :

[falcon900]

Bonjour à tous,*

J'ai une liste ci-dessous issue d'un fichier xml (chaque ligne est copiée dans une cellule xls).

* * * * * * * * <Partie pk="5668" lk="[LF][SIV CLERMONT][3]">
* * * * * * * * <Espace pk="1586" lk="[LF][SIV CLERMONT]"/>
* * * * * * * * <NomPartie>3</NomPartie>
* * * * * * * * <Geometrie>46.5,4.4
46.175,4.05
46.05,3.853889
46.307222,4.731111
46.5,4.674722
46.5,4.4</Geometrie>
* * * * * * </Partie>
* * * * * * <Partie pk="5667" lk="[LF][SIV CLERMONT][2]">
* * * * * * * * <Espace pk="1586" lk="[LF][SIV CLERMONT]"/>
* * * * * * * * <NomPartie>2</NomPartie>
* * * * * * * * <Geometrie>47.359167,4.270833
46.5,4.674722
46.583333,4.65
46.88,4.366944
47.359167,4.270833</Geometrie>
* * * * * * </Partie>

J'ai besoin d'extraire dans une colonne uniquement les data suivantes (il y a des dizaines de milliers de lignes) :*

- Nom de partie*

- Donnée géométrie (liste)

Le programme sera du genre SI la cellule contient Partie pk alors récupérer la valeur*lk.

Puis en dessous afficher*L.polygon([*

Puis en dessous afficher la liste des cellules entre <Geometrie> et <\Geometrie>

Exemple ci-dessous :**

[SIV CLERMONT][3]

46.5,4.4
46.175,4.05
46.05,3.853889
46.307222,4.731111
46.5,4.674722
46.5,4.4

Merci pour votre aide.

Dans le début du programme j'ai essayé ca mais ca ne fonctionne pas. J'ai l'impression que c'est Cells(i, 1).Value Like "*Partie pk*" qui ne fonctionne pas.

Sub loop_do_while()

Dim i As String
i = 1

Do While Cells(i, 1).Value <> ""
Cells(i, 1).Value Like "*Partie pk*"
Cells(i, 2).Value = Cells(i, 1)

i = i + 1

Loop

End Sub

[ARTURO83]

Bonjour,

Essayez ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub Extraction()
    Dim i As Long, DerLig As Long, Chevron As Long, Crochet As Long
    Dim Cell As String
    Application.ScreenUpdating = False
    DerLig = Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To DerLig
        If Cells(i, 1) <> "" Then
            If Cells(i, 1).Value Like "*Partie pk*" Then
                Cell = Replace(Replace(Cells(i, 1), "[LF]", ""), """", "")
                Crochet = InStr(1, Cell, "[", 1)
                Cells(i, 2) = Mid(Cell, Crochet, Len(Cell) - Crochet)
                Cells(i + 1, 2) = "*L.polygon([*"
                i = i + 1
            ElseIf Cells(i, 1).Value Like "*Geometrie*" Then
                Chevron = InStrRev(Cells(i, 1), ">", -1)
                If Len(Cells(i, 1)) > Chevron Then
                    Cells(i, 2) = Mid(Cells(i, 1), Chevron + 1, Len(Cells(i, 1)) - Chevron)
                Else
                    Chevron = InStr(1, Cells(i, 1), "<", 1)
                    Cells(i, 2) = Left(Cells(i, 1), Chevron - 1)
                End If
            ElseIf Left(Cells(i, 1), 1) <> "*" Then
                Cells(i, 2) = Cells(i, 1)
            Else: Cells(i, 2) = ""
            End If
        End If
    Next
End Sub

Cdlt

[falcon900]

Ca fonctionne parfaitement !
Merci !