Import multiple page web chacune dans une nouvelle feuille [Résolu]

Goth!er 10 Messages postés jeudi 10 novembre 2016Date d'inscription 30 novembre 2017 Dernière intervention - 7 nov. 2017 à 14:13 - Dernière réponse : Goth!er 10 Messages postés jeudi 10 novembre 2016Date d'inscription 30 novembre 2017 Dernière intervention
- 7 nov. 2017 à 16:08
Bonjour le forum,

Quelqu'un aurait la solution pour importer le contenu de plusieurs urls de ma feuille et que pour chaque Url, Excel crée une nouvelle feuille dédiée ?
Actuellement mon code me permet de charger toutes les données à la suite les unes des autres juste en dessous de mes urls.
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


Afficher la suite 
10Messages postés jeudi 10 novembre 2016Date d'inscription 30 novembre 2017 Dernière intervention

2 réponses

Répondre au sujet
yg_be 4106 Messages postés lundi 9 juin 2008Date d'inscriptionContributeurStatut 10 décembre 2017 Dernière intervention - 7 nov. 2017 à 15:56
0
Utile
1
bonjour, suggestion:
Sub test1()
Dim nouvsh As Worksheet

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
            Set nouvsh = Worksheets.Add(, Worksheets(Worksheets.Count))
            nouvsh.Name = "URL" & CStr(I)
            'lrc = .Cells(Rows.Count, "A").End(xlUp).Row 'last row in C column
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;" & A, Destination:=nouvsh.[A1])
                .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
End Sub
Goth!er 10 Messages postés jeudi 10 novembre 2016Date d'inscription 30 novembre 2017 Dernière intervention - 7 nov. 2017 à 16:08
Ca Marche nickel !!!

Merci
Commenter la réponse de yg_be