Microsoft 365 Rangement de données et tri

[Mathieu49000]

Bonjour, j'ai obtenu des données sur un site de voyage, j'ai réuni différentes informations sur une seule et même colonne. Il y a : la référence, longitude, latitude, le nom, la destination, le prix et le lieu. Je souhaite transposer tout ça dans un tableau classé par référence (une ligne par référence et les informations liées dans les colonnes suivantes).

Toutes les références ne contiennent pas toutes les informations si dessus, je ne peux donc pas faire toutes les 7 lignes..

Si jamais vous avez la solution c'est avec un grand merci !

Voici le lien drive de la base de données Word ou en Excel : https://drive.google.com/drive/folders/1mVTMAn3TJzACgGgydPxQbvdaD77D1hov?usp=share_link

PS : Le but de ce travail est d'introduire le tableau dans une map Bing ou Google My Maps afin d'avoir une puce pour toutes les destinations possibles.

 

[sylvanu]

Bonsoir Mathieu, et bienvenu sur XLD,
Un essai en PJ ( LIEN ) avec :

Sub Extraction()
    [A2:H65000].ClearContents
    Application.ScreenUpdating = False
    Set F = Sheets("Synthèse")
    With Sheets("matthieu-end")
        Lig = 2  ' ligne d'écriture
        DL = .Range("A65500").End(xlUp).Row
        For L = 2 To DL
            T = Split(.Cells(L + 0, "A"), "=")
            Select Case T(0)
                Case "data-product-ref": F.Cells(Lig, "A") = T(1)
                Case "data-product-longitude": F.Cells(Lig, "B") = T(1)
                Case "data-product-latitude": F.Cells(Lig, "C") = T(1)
                Case "data-product-name": F.Cells(Lig, "D") = T(1)
                Case "data-product-destination": F.Cells(Lig, "E") = T(1)
                Case "data-product-base-price-availability": F.Cells(Lig, "F") = T(1)
                Case "data-product-link"
                    F.Cells(Lig, "G") = T(1)
                    Lig = Lig + 1
            End Select
            Application.StatusBar = "Progression : " & L & " sur " & DL
        Next L
    End With
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, ReplaceFormat:=False
    Application.StatusBar = ""
End Sub

C'est lent, très lent.
J'essaierais d'avoir un peu de temps ce soir pour l'accélérer.

 

[sylvanu]

Re,
Nouvelle mouture beaucoup plus rapide : LIEN

Sub Extraction()
    [A2:H65000].ClearContents
    Application.ScreenUpdating = False
    Set f = Sheets("Synthèse")
    With Sheets("matthieu-end")
        Nb = 1: Lig = 0 ' ligne d'écriture
        DL = .Range("A65500").End(xlUp).Row
        tablo = .Range("A2:A" & DL)
        P = Application.CountIf(.Range("A:A"), "data-product-ref=*") + 1 ' Nb REF
        ReDim Tout(P, 6)
        For L = 1 To UBound(tablo)
            T = Split(tablo(L, 1), "=")
            Chaine = T(1)
            Select Case T(0)
                Case "data-product-ref":            Tout(Lig, 0) = Chaine
                Case "data-product-longitude":      Tout(Lig, 1) = Chaine
                Case "data-product-latitude":       Tout(Lig, 2) = Chaine
                Case "data-product-name":           Tout(Lig, 3) = Chaine
                Case "data-product-destination":    Tout(Lig, 4) = Chaine
                Case "data-product-base-price-availability": Tout(Lig, 5) = Chaine
                Case "data-product-link"
                    Tout(Lig, 6) = Chaine
                    Lig = Lig + 1
            End Select
            Nb = Nb + 1
            If Nb = 100 Then
                Application.StatusBar = "Progression : " & Lig & " sur " & P
                Nb = 1
            End If
        Next L
    End With
    Sheets("Synthèse").Range("$A$2").Resize(UBound(Tout, 1), 1 + UBound(Tout, 2)) = Tout
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, ReplaceFormat:=False
    Application.StatusBar = ""
    Application.ScreenUpdating = True
Fin:
End Sub

 

[Mathieu49000]

Re,
Nouvelle mouture beaucoup plus rapide : LIEN

Sub Extraction()
    [A2:H65000].ClearContents
    Application.ScreenUpdating = False
    Set f = Sheets("Synthèse")
    With Sheets("matthieu-end")
        Nb = 1: Lig = 0 ' ligne d'écriture
        DL = .Range("A65500").End(xlUp).Row
        tablo = .Range("A2:A" & DL)
        P = Application.CountIf(.Range("A:A"), "data-product-ref=*") + 1 ' Nb REF
        ReDim Tout(P, 6)
        For L = 1 To UBound(tablo)
            T = Split(tablo(L, 1), "=")
            Chaine = T(1)
            Select Case T(0)
                Case "data-product-ref":            Tout(Lig, 0) = Chaine
                Case "data-product-longitude":      Tout(Lig, 1) = Chaine
                Case "data-product-latitude":       Tout(Lig, 2) = Chaine
                Case "data-product-name":           Tout(Lig, 3) = Chaine
                Case "data-product-destination":    Tout(Lig, 4) = Chaine
                Case "data-product-base-price-availability": Tout(Lig, 5) = Chaine
                Case "data-product-link"
                    Tout(Lig, 6) = Chaine
                    Lig = Lig + 1
            End Select
            Nb = Nb + 1
            If Nb = 100 Then
                Application.StatusBar = "Progression : " & Lig & " sur " & P
                Nb = 1
            End If
        Next L
    End With
    Sheets("Synthèse").Range("$A$2").Resize(UBound(Tout, 1), 1 + UBound(Tout, 2)) = Tout
    Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, ReplaceFormat:=False
    Application.StatusBar = ""
    Application.ScreenUpdating = True
Fin:
End Sub

Ouahh c'est exactement ce que je voulais un énorme merci !! J'aimerais fortement plus en comprendre, il y'a t-il un endroit pour commencer ?
Merci encore pour ce travail !!

 

[sylvanu]

Bonsoir,

il y'a t-il un endroit pour commencer ?

Vaste choix.
Peut être par le début avec notre ami David : https://excel-downloads.com/media/categories/vba.4/
sinon des tonnes sur internet ... et de l'huile de coude.

 

[Mathieu49000]

Bonsoir,

Vaste choix.
Peut être par le début avec notre ami David : https://excel-downloads.com/media/categories/vba.4/
sinon des tonnes sur internet ... et de l'huile de coude.

Génial merci je vais consulter !

Et chose que j'ignorais, les cartes sont limitées en nombre de puces à insérer, connais-tu une manière de pallier ce problème ? Bing Map à l'air de se limiter à 100 données et Google My Maps 10 calques de 2000 lignes. J'ai au pire 25000 lignes à mettre..

Désolé pour l'embêtement..

 

[sylvanu]

les cartes sont limitées en nombre de puces à insérer,

Je ne le savais pas.
Mais je pense plutôt que ces limitations sont sur les versions gratuites, ... mais c'est débridé sur les versions payantes.
Je sais que Maps est payant, il offre alors beaucoup plus de services, dont surement celui là.
En tout cas, je ne connais pas la manière de contourner le problème, si ce n'est de découper en plusieurs cartes.

 

[Mathieu49000]

Je ne le savais pas.
Mais je pense plutôt que ces limitations sont sur les versions gratuites, ... mais c'est débridé sur les versions payantes.
Je sais que Maps est payant, il offre alors beaucoup plus de services, dont surement celui là.
En tout cas, je ne connais pas la manière de contourner le problème, si ce n'est de découper en plusieurs cartes.

Oui c'est ce que j'avais imaginé faire ou utiliser Power Map mais je ne m'y connais pas encore assez. En tout cas je me renseigne sur le sujet merci pour ce pas de géant que tu m'as permis de faire ! Je te tiens au courant si je trouve une solution magique