Ajouter une colonne supplémentaire lors d'un import web

Résolu
Goth!er Messages postés 15 Date d'inscription   Statut Membre Dernière intervention   -  
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour le forum,

Après de nombreuses heures de recherche sur le web je suis finalement parvenu à un code VBA fonctionnel pour l'import de données suivant plusieurs url contenues dans une feuille... J'aimerais maintenant que pour chaque ligne ajoutée, le nom de la source soit indiqué dans une nouvelle colonne supplémentaire..

Ex : en A les urls, en B le nom de la source

L'import de l'URL A2 crée 250 lignes , il faudrait qu'en Z le code ajoute le contenu de B2 pour les 250 lignes créées.
L'import de l'Url A3 crée 173 lignes , en Z pour ces 173 lignes le contenu de B3

Le nombre de lignes importées est aléatoire pour chaque url.

Je suis impatient de voir vos idées.

Merci déjà d'avance de vos réponses
A voir également:

5 réponses

Réponse 1 / 5
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 584
 
Je suis impatient de voir ton code, et de le compléter.
0
Goth!er
 
Bonjour yg_be,
Merci pour ton intérêt 


Sub test1()

Sheets("Urls").Select
    ActiveCell.Select
  
Dim I As Long, A As String
' declaring variables
With ActiveSheet
    I = 2
    Do
        A = .Cells(I, 1).Value
        If A <> "" Then
            lrc = .Cells(Rows.Count, "A").End(xlUp).Row 'last row in C column
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;" & A, Destination:=Cells(lrc + 1, "A"))
                .Name = I
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertEntireRows
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlAllTables
                .WebFormatting = xlWebFormattingNone
                '.WebTables = "1,2"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
        End If
        I = I + 1
    Loop Until A = ""
End With
Beep
Sheets("Checking").Select
    
End Sub

Fonctionne tres bien si ce n'est qu'il importe les données sous la liste d' URLS... si tu sais comment modifier cela aussi ce serait nickel :-)
0
Réponse 2 / 5
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 584
 
Proposition : 
Option Explicit
Sub test1()

Sheets("Urls").Select
    ActiveCell.Select
  
Dim I As Long, A As String
Dim B As String
Dim lrc As Long
Dim newlrc As Long
Dim nligne As Long



' declaring variables
With ActiveSheet
    I = 2
    Do
        A = .Cells(I, 1).Value
        B = .Cells(I, 2).Value 'source
        If A <> "" Then
            lrc = .Cells(Rows.Count, "A").End(xlUp).Row 'last row in C column
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;" & A, Destination:=Cells(lrc + 1, "A"))
                .Name = I
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertEntireRows
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlAllTables
                .WebFormatting = xlWebFormattingNone
                '.WebTables = "1,2"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
            newlrc = .Cells(Rows.Count, "A").End(xlUp).Row ' new last row
            For nligne = lrc + 1 To newlrc
                .Cells(nligne, 26) = B
            Next
        End If
        I = I + 1
    Loop Until A = ""
End With
Beep
Sheets("Checking").Select
    
End Sub

Je n'ai pas changé où il importait les données, je ne sais pas où tu souhaites que cela aille. Si tu veux le changer, c'est déterminé par : 
Destination:=Cells(lrc + 1, "A")

Si tu changes cela, attention à changer aussi la logique de stockage de la source en colonne Z : 
For nligne = lrc + 1 To newlrc
      .Cells(nligne, 26) = B
Next
0
Goth!er
 
Merci,
Je vais tester !

Pour faire simple disons je souhaite que ca aille en "Sheet2" tout simplement cela donnerait quoi ?

je te reviens tout de suite après test !
0
Goth!er
 
Je valide ! :-) E- norm- eeeee Trop trop top !!!

si tu savais juste me montrer avec le résultat en "Sheet2" ... je serais comblé !

:-)
0
Réponse 3 / 5
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 584
 
Tout vers "Sheet2" : 
Option Explicit
Sub test1()

Sheets("Urls").Select
    ActiveCell.Select
  
Dim I As Long, A As String
Dim B As String
Dim lrc As Long
Dim newlrc As Long
Dim nligne As Long



' declaring variables
With ActiveSheet
    I = 2
    Do
        A = .Cells(I, 1).Value
        B = .Cells(I, 2).Value 'source
        If A <> "" Then
            lrc = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row 'last row in C column
            With Sheets("Sheet2").QueryTables.Add(Connection:= _
                "URL;" & A, Destination:=Sheets("Sheet2").Cells(lrc + 1, "A"))
                .Name = I
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertEntireRows
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlAllTables
                .WebFormatting = xlWebFormattingNone
                '.WebTables = "1,2"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
            newlrc = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row ' new last row
            For nligne = lrc + 1 To newlrc
                Sheets("Sheet2").Cells(nligne, 26) = B
            Next
        End If
        I = I + 1
    Loop Until A = ""
End With
Beep
Sheets("Checking").Select
    
End Sub
0
Goth!er
 
Ok, Nickel ca fonctionne.

Encore une dernière question , vois-tu quelque chose dans le code qui expédie les données de la première url en D,alors que les suivantes fonctionnent à merveilles et débutent bien à la suite mais en A
0
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   1 584
 
Pas d'idée. Et si tu changes l'ordre des urls? C'est peut-être la première qui est spéciale?
Je peux tester si tu m'envoies quelques exemples d'urls : ce que j'essaie donne un peu n'importe quoi.
(vois ci-dessous une version meilleure, mais rien à voir avec ton dernier soucis)
0
Réponse 4 / 5
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 584
 
Mon dernier mot : 
Option Explicit
Sub test1()
  
Dim I As Long, A As String
Dim B As String
Dim lrc As Long
Dim newlrc As Long
Dim nligne As Long
Dim fsource As Worksheet, fdest As Worksheet
Dim qt As QueryTable

Set fsource = Sheets("Urls")
Set fdest = Sheets("Sheet2")

For Each qt In fdest.QueryTables 'nettoyage des anciens "QueryTables.Add"
    qt.Delete
Next
I = 2
Do
    A = fsource.Cells(I, 1).Value
    B = fsource.Cells(I, 2).Value 'source
    If A <> "" Then
        lrc = fdest.Cells(Rows.Count, "A").End(xlUp).Row 'last row in C column
        With fdest.QueryTables.Add(Connection:= _
            "URL;" & A, Destination:=fdest.Cells(lrc + 1, "A"))
            .Name = I
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertEntireRows
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlAllTables
            .WebFormatting = xlWebFormattingNone
            '.WebTables = "1,2"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        newlrc = fdest.Cells(Rows.Count, "A").End(xlUp).Row ' new last row
        For nligne = lrc + 1 To newlrc
            fdest.Cells(nligne, 26) = B
        Next
    End If
    I = I + 1
Loop Until A = ""
Beep
'Sheets("Checking").Select
End Sub
0
Goth!er
 
Re,

Idem , le premier import est décalé ...
Je teste tout simplement avec :
A2 :https://forums.commentcamarche.net/forum/bureautique-25 B2:bureautique
A3: https://forums.commentcamarche.net/forum/excel-145 B3 :Excel

En sheet2 , le 1er import débute en colonne D , le suivant en colonne A ...
0
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   1 584
 
En fait, c'est plus compliqué et plus embêtant que cela : les premiers urls se mettent bien, et, parfois, un url suivant insère trois colonnes, donc décale les premiers (inclus la colonne Z des premiers).
Je suspecte que c'est lié à la logique qui met le texte en colonnes.
Ce comportement disparaît en changeant : 
.WebPreFormattedTextToColumns = False

Tu avais besoin de mettre le texte en colonnes? Maintenant tout le texte est en A.
0
Goth!er
 
mmh ... j'ai effectivement besoin des colonnes.

En réalité, j'importe des données clients via ce procédé , ce qui constitue la base de données.
Ca fonctionnais nickel, excepté 1 chose , je ne parvenais pas identifier de quel magasin était le client... la donnée de magasin n’étant pas dans l'import.

Ton complément fonctionne parfaitement et rempli ce manquement !

Reste juste ce petit décalage énervant , la recherche client étant basée sur un VLOOKUP par numéro de client dans la colonne A ... les clients de l'import décalés ne seront pas détecté et les infos non remontées..
0
yg_be Messages postés 23541 Date d'inscription   Statut Contributeur Dernière intervention   1 584
 
Et tu as également ce décalage avec tes "vrais" urls? C'est peut-être lié au contenu des réponses.
0
Goth!er
 
Ca fonctionne !!!

l'erreur était dans le code ... 

.WebFormatting = xlWebFormattingNone
            '.WebTables = "1,2"
            .WebPreFormattedTextToColumns = Tru


WebTables est en commentaire !!! 

.WebFormatting = xlWebFormattingNone
            .WebTables = "1,2"
            .WebPreFormattedTextToColumns = True


et ca a l'air de fonctionner !!!!

Mille Mercis !!!

Pour un premier post sur un forum, l’expérience fut extra et cela grâce à toi !!
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 5
Utilisateur anonyme
 
Bonjour Goth!er, tu es un fan d'Ach!lle Talon ? Greg  😉
-1
Goth!er
 
Bonjour albkan ,
Je connais la bd , mais je n'avais jamais vu le "!" ... dans mon cas c'est du à mon passé d'animateur scout , ca avait de la gueule sur mon pull ... mieux que le 'Gauthier' classique :p
0