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

Résolu
Goth!er Messages postés 16 Statut Membre -  
yg_be Messages postés 23437 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

5 réponses

  1.
    yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 588
     
    Je suis impatient de voir ton code, et de le compléter.
    0
    1. 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
  2. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 588
     
    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
    1. 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
    2. 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
  3. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 588
     
    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
    1. 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
    2. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588
       
      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
  4. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 588
     
    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
    2. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588
       
      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
    3. 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
    4. yg_be Messages postés 23437 Date d'inscription   Statut Contributeur Dernière intervention   1 588
       
      Et tu as également ce décalage avec tes "vrais" urls? C'est peut-être lié au contenu des réponses.
      0
    5. 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

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

    Posez votre question
  6. Utilisateur anonyme
     
    Bonjour Goth!er, tu es un fan d'Ach!lle Talon ? Greg  😉
    -1
    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

Discussions similaires

Comment s’inscrire sur célibataire du web
Mimi412 -
MPMP10 -

6 réponses