Extraction données web/excel VBA [Résolu/Fermé]

Signaler
Messages postés
6
Date d'inscription
samedi 14 janvier 2017
Statut
Membre
Dernière intervention
17 janvier 2017
-
Messages postés
6
Date d'inscription
samedi 14 janvier 2017
Statut
Membre
Dernière intervention
17 janvier 2017
-
Bonjour,

Je connais absolument rien sur VBA (plutôt bricoleur)
Je suis tombé sur la page ci-dessous et la solution proposé réponds parfaitement à mon besoin sauf que je dois l'adapter.

La page en question la voici :
https://forums.commentcamarche.net/forum/affich-25514152-automatiser-extraction-donnees-web-excel-vba
Au passage un grand merci à "eriiic" pour sa contribution et solution .
En résumer le code extrait des données à partir du web sur l'Excel dans la feuille1. une fois le macro activé sur la feuille1 on importe des données sur la feuille2 en haut ou bas des mots de références. et les données recherchés sont recherchés à partir des mots de référence qui se situes sur la même ligne.

le voici le code (lien de la solution proposé par "eriiic" https://www.cjoint.com/c/CCCpj40Y2dj )
---------------------------
Sub MAJ()
Dim i As Long, ws As Worksheet, savbarre As String
Dim c As Range, décalage As String
' mettre Feuil2 en variable pour raccourcir le code et qu'il soit plus lisible
Set ws = Worksheets("Feuil2")
'activer Feuil1 recevant la requête web
Worksheets("Feuil1").Select
Worksheets("Feuil1").[A1].Select
'sauvegarde état barre d'état en bas
savbarre = Application.DisplayStatusBar
' activer barre d'état
Application.DisplayStatusBar = True
derlig = ws.[B65536].End(xlUp).Row
For i = 5 To derlig ' pour chaque ligne d'adresse web
' mettre à jour le n° du site dans la barre d'état
Application.StatusBar = "Site " & i - 4 & "/" & derlig - 4 & " en cours..."
'modifier la requete web
With Selection.QueryTable
'la faire pointer sur la nouvelle adresse
.Connection = "URL;" & ws.Cells(i, 2).Value
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
' mettre à jour les données du site (dans feuil2) à partir des données de la requête
With ws
For col = 3 To .Cells(4, Columns.Count).End(xlToLeft).Column
Set c = Cells.Find(.Cells(4, col), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
décalage = .Cells(3, col)
.Cells(i, col) = c.Offset(Split(décalage, "-")(0), Split(décalage, "-")(1))
Else
.Cells(i, col) = "non trouvé"
End If
Next col
End With
Next i ' site suivant
'
'rétablir l'état de la barre d'état
Application.DisplayStatusBar = savbarre
Set ws = Nothing
End Sub
---------------
Ma question est la suivante (trop facile pour certains mais trop complexe pour moi)
Comment ajouter une fonction(ou variable) dans le code pour pouvoir récupérer toujours le même principe ( de la feuille1 vers la feuille2) une partie de texte d'une cellule ? exemple :
Je cherche à afficher sur la feuille2 ( même principe du code ci-haut) le texte "une voiture bleu" qui se trouve dans une cellule de la feuille1 "couleur du véhicule : une voiture bleu" ?

Merci à vous de votre aide

1 réponse

Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020
6 409
Bonjour,

c'est vague...
Donc l'essentiel, à adapter à ton besoin :
Sub test()
    Dim c As Range, ch As String
    ch = "couleur du véhicule : "    ' respecter accents et majuscules
    Set c = Cells.Find(ch, LookIn:=xlValues, lookat:=xlPart)
    If c Is Nothing Then
        MsgBox "non trouvé"
    Else
        MsgBox Mid(c.Value, Len(ch) + 1)
    End If
End Sub

eric
Messages postés
6
Date d'inscription
samedi 14 janvier 2017
Statut
Membre
Dernière intervention
17 janvier 2017
>
Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020

Bonjour Eric,
En postant l'image c'était une façon pour moi d’apporter d’élément complémentaire sur ma demande histoire d’être plus clair, désolé d'avoir pollué le forum...
Pour les données url (fonctionnel) en fait ça concerne des données de l'intranet de mon employeur je ne peux en dire + tous ce que je peux dire l'extraction concernent les statuts documentaire (parcours d’approbation chez nous est très long) ;
En effet je reçois un reporting hebdomadaire par un collègue (extraction depuis un logiciel improntu (un truc du genre) et strictement réservé à quelque personne) sauf qu’à chaque fois je dois relancer ou courir derrière.
Donc pendant les vacances de cette personne je m’amuse à rechercher document par document.
Un petit d’exemple de résultats du Requête sur un document : Référence, indice de révision, cause de révision, type documents, langue, Statut, entité de l'auteur, niveau de confidentialité, norme, niveau qualité, contrat, nom de l’approbateur.... (J’ai la possibilité de limiter les critères)
En vue de ces données qui m’intéresse, je dois planifier ma liste de route donc une série d’action (lancement, relance, identification des urgences...) étaler sur deux semaines.
Ton macro fonctionne parfaitement comme je souhaite pour quelque données situé sur la colonne A:B. https://www.cjoint.com/c/GArf32gkTks
D’où ma demande initiale comment extraire une partie du texte comme exemple :
Ligne 8 : Extraire la référence documentaire « ABCDEF12-XYZ0153 » de la cellule qui contient « Référence : ABCDEF12-XYZ0153 »
Nota : dans le fichier .xls . Etant des liens d’intranet de mon employeur, je me dois dans l’obligation de nettoyer le résultat et préserver la confidentialité, désolé.
Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020
6 409
Bonjour,

Si la partie extraction url fonctionne bien, un exemple de page ramenée suffit.
Ne pas mettre d'offset et faire suivre la chaine recherchée de *
Code complété : https://www.cjoint.com/c/GArhDlj07RJ
eric
Messages postés
6
Date d'inscription
samedi 14 janvier 2017
Statut
Membre
Dernière intervention
17 janvier 2017
>
Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020

Bonjour et merci Eric,
Je regarderais chez moi ce soir (site cjoint est bloqué au boulot)

Merci encore
Thomas
Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020
6 409
Saisir
Référence : *
en E4.

Sub MAJ()
    Dim i As Long, ws As Worksheet, savbarre As String
    Dim c As Range, décalage As String
    ' mettre Feuil2 en variable pour raccourcir le code et qu'il soit plus lisible
    Set ws = Worksheets("Feuil2")
    'activer Feuil1 recevant la requête web
    Worksheets("Feuil1").Select
    Worksheets("Feuil1").[A1].Select
    'sauvegarde état barre d'état en bas
    savbarre = Application.DisplayStatusBar
    ' activer barre d'état
    Application.DisplayStatusBar = True
    derlig = ws.[B65536].End(xlUp).Row
    For i = 5 To derlig    ' pour chaque ligne d'adresse web
        ' mettre à jour le n° du site dans la barre d'état
        Application.StatusBar = "Site " & i - 4 & "/" & derlig - 4 & " en cours..."
        'modifier la requete web
        With Selection.QueryTable
            'la faire pointer sur la nouvelle adresse
            .Connection = "URL;" & ws.Cells(i, 2).Value
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = False
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingNone
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        ' mettre à jour les données du site (dans feuil2) à partir des données de la requête
        With ws
            For col = 3 To .Cells(4, Columns.Count).End(xlToLeft).Column
                If .Cells(3, col) = "" Then
                    If Right(.Cells(4, col), 1) = "*" Then
                        'extraire chaine après
                        Set c = Cells.Find(.Cells(4, col), LookIn:=xlValues, lookat:=xlPart)
                        If Not c Is Nothing Then
                            .Cells(i, col) = Mid(c, Len(.Cells(4, col)))
                        Else
                            .Cells(i, col) = "non trouvé"
                        End If
                    ElseIf Left("e", 1) = "*" Then
                        'extraire chaine avant
                        Set c = Cells.Find(.Cells(4, col), LookIn:=xlValues, lookat:=xlPart)
                        If Not c Is Nothing Then
                            .Cells(i, col) = Left(c, Len(c) - Len(.Cells(4, col)) - 1)
                        Else
                            .Cells(i, col) = "non trouvé"
                        End If

                    End If
                Else
                    'retourner cellule offset x-y
                    Set c = Cells.Find(.Cells(4, col), LookIn:=xlValues, lookat:=xlWhole)
                    If Not c Is Nothing Then
                        décalage = .Cells(3, col)
                        .Cells(i, col) = c.Offset(Split(décalage, "-")(0), Split(décalage, "-")(1))
                    Else
                        .Cells(i, col) = "non trouvé"
                    End If
                End If
            Next col
        End With
    Next i        ' site suivant
    '
    'rétablir l'état de la barre d'état
    Application.DisplayStatusBar = savbarre
    Set ws = Nothing
End Sub
Messages postés
6
Date d'inscription
samedi 14 janvier 2017
Statut
Membre
Dernière intervention
17 janvier 2017
>
Messages postés
23574
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
17 octobre 2020

Grand MERCI eric ça fonctionne comme je veux.

Merci encore pour ta patience et ton professionnalisme

Thomas