extraction données web/excel VBA Résolu/Fermé

Question

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
Configuration: Windows / Edge 14.14393

eriiic · Answer

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

Extraction données web/excel VBA

1 réponse

Discussions similaires