Ajouter une colonne supplémentaire lors d'un import web Résolu/Fermé

Question

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

yg_be · Answer

Je suis impatient de voir ton code, et de le compléter.

Utilisateur anonyme · Answer

Bonjour Goth!er, tu es un fan d'Ach!lle Talon ? Greg  &#x1F609;

yg_be · Answer

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

yg_be · Answer

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

yg_be · Answer

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

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

5 réponses

Discussions similaires