VBA xls - Récupérer cellules dans liste

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

Bonjour,

Essayez ceci:

Code:

---

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

Ca fonctionne parfaitement !
Merci !