Récupération multi-page en VBA pour le WEB

Résolu
maximedu45 -  
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

Je cherche à récupérer des données sur internet, le problème c'est que j'ai réaliser un code basic en VBA pour récupérer les fiches et les triées une à une mais j'en est 9000 à faire et je n'arrive pas à automatiser mon code.

Je cherche à faire en sorte que le i (qui change le numéro dans mon lien internet commence à 0 puis 1 , 2 ... 9000 à chaque fois qu'il a terminé de faire la récupération)

Le problème c'est qu'il y a des pages qui ne fonctionne pas !!

Je travail sur Office 2007 sur Windows PC.

Je remercie d'avance ceux qui prendront le temps de regarder.

Voici le code

Sub importer()

i = 1023
With Sheets("TEMP").QueryTables.Add(Connection:= _
"URL;http://www.mineralinfo.fr/Fiches/carmat/" & i, Destination:=Sheets("TEMP").Range( _
"$A$1"))
.Name = "4"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With

compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 3) = "Nom" Then
Sheets("ACCUEIL").Cells(i, compteur) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 1 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Exploitée" Then
Sheets("ACCUEIL").Cells(i, compteur + 1) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 2 Then Exit For
End If

Next

compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 5) = "Fiche" Then
Sheets("ACCUEIL").Cells(i, compteur + 2) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 3 Then Exit For
End If

Next

compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 11) = "Département" Then
Sheets("ACCUEIL").Cells(i, compteur + 3) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 4 Then Exit For
End If

Next

compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Commune" Then
Sheets("ACCUEIL").Cells(i, compteur + 4) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 5 Then Exit For
End If

Next

compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Code P" Then
Sheets("ACCUEIL").Cells(i, compteur + 5) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 6 Then Exit For
End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Numéro" Then
Sheets("ACCUEIL").Cells(i, compteur + 6) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 7 Then Exit For
End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Code B" Then
Sheets("ACCUEIL").Cells(i, compteur + 7) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 8 Then Exit For
End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 4), 3) = "Fin" Then
Sheets("ACCUEIL").Cells(i, compteur + 8) = Sheets("TEMP").Cells(ligne + 1, 4)
If compteur = 9 Then Exit For
End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Statut" Then
Sheets("ACCUEIL").Cells(i, compteur + 9) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 10 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 4) = "Type" Then
Sheets("ACCUEIL").Cells(i, compteur + 10) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 10 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 13) = "Réaménagement" Then
Sheets("ACCUEIL").Cells(i, compteur + 11) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 12 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 7) = "Hauteur" Then
Sheets("ACCUEIL").Cells(i, compteur + 12) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 13 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Epaisseur" Then
Sheets("ACCUEIL").Cells(i, compteur + 13) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 14 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 10) = "Profondeur" Then
Sheets("ACCUEIL").Cells(i, compteur + 14) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 15 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 7) = "Surface" Then
Sheets("ACCUEIL").Cells(i, compteur + 15) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 16 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 8) = "Géologie" Then
Sheets("ACCUEIL").Cells(i, compteur + 16) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 17 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Typologie" Then
Sheets("ACCUEIL").Cells(i, compteur + 17) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 18 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 3) = "Age" Then
Sheets("ACCUEIL").Cells(i, compteur + 18) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 19 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 11) = "Morphologie" Then
Sheets("ACCUEIL").Cells(i, compteur + 19) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 20 Then Exit For

End If

Next
compteur = 1
For ligne = 1 To 100
If Left(Sheets("TEMP").Cells(ligne, 1), 10) = "Lithologie" Then
Sheets("ACCUEIL").Cells(i, compteur + 20) = Sheets("TEMP").Cells(ligne, 1)
If compteur = 21 Then Exit For

End If

Sheets(Array("Temp")).Select
Cells.Select
Selection.ClearContents

Next

End Sub


A voir également:

2 réponses

Réponse 1 / 2
yg_be Messages postés 24281 Date d'inscription   Statut Contributeur Dernière intervention   Ambassadeur 1 585
 
bonsoir, tu écris "Le problème c'est qu'il y a des pages qui ne fonctionne pas !!".
Je ne comprends pas le problème, ni le lien avec la valeur de i.
0
Réponse 2 / 2
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   4 728
 
Bonjour,

Ta macro arrangée à ma façon : tu vérifies le n° de départ et celui de fin 
Sub importer()
Dim i As Long, ligne As Long
Const deb = 1021    ' fiche début - 2 (à ajuster)
For i = 2 To 9000
    On Error Resume Next
    With Sheets("TEMP").QueryTables.Add(Connection:= _
        "URL;http://www.mineralinfo.fr/Fiches/carmat/" & i + deb, Destination:=Sheets("TEMP").Range( _
        "$A$1"))
        .Name = "4"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    If Err.Number = 0 Then
        For ligne = 1 To 100
            If Left(Sheets("TEMP").Cells(ligne, 1), 3) = "Nom" Then
                Sheets("ACCUEIL").Cells(i, 1) = Mid(Sheets("TEMP").Cells(ligne, 1), 7)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Exploitée" Then
                Sheets("ACCUEIL").Cells(i, 2) = Mid(Sheets("TEMP").Cells(ligne, 1), 16)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 5) = "Fiche" Then
                Sheets("ACCUEIL").Cells(i, 3) = Mid(Sheets("TEMP").Cells(ligne, 1), 9)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 11) = "Département" Then
                Sheets("ACCUEIL").Cells(i, 4) = Mid(Sheets("TEMP").Cells(ligne, 1), 14)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Commune" Then
                Sheets("ACCUEIL").Cells(i, 5) = Mid(Sheets("TEMP").Cells(ligne, 1), 10)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Code P" Then
                Sheets("ACCUEIL").Cells(i, 6) = Mid(Sheets("TEMP").Cells(ligne, 1), 14)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Numéro" Then
                Sheets("ACCUEIL").Cells(i, 7) = Mid(Sheets("TEMP").Cells(ligne, 1), 8)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Code B" Then
                Sheets("ACCUEIL").Cells(i, 8) = Mid(Sheets("TEMP").Cells(ligne, 1), 12)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 4), 3) = "Fin" Then
                Sheets("ACCUEIL").Cells(i, 9) = Sheets("TEMP").Cells(ligne + 1, 4)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 6) = "Statut" Then
                Sheets("ACCUEIL").Cells(i, 10) = Mid(Sheets("TEMP").Cells(ligne, 1), 10)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 4) = "Type" Then
                Sheets("ACCUEIL").Cells(i, 11) = Mid(Sheets("TEMP").Cells(ligne, 1), 20)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 13) = "Réaménagement" Then
                Sheets("ACCUEIL").Cells(i, 12) = Mid(Sheets("TEMP").Cells(ligne, 1), 17)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 7) = "Hauteur" Then
                Sheets("ACCUEIL").Cells(i, 13) = Mid(Sheets("TEMP").Cells(ligne, 1), 28)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Epaisseur" Then
                Sheets("ACCUEIL").Cells(i, 14) = Mid(Sheets("TEMP").Cells(ligne, 1), 25)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 10) = "Profondeur" Then
                Sheets("ACCUEIL").Cells(i, 15) = Mid(Sheets("TEMP").Cells(ligne, 1), 23)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 7) = "Surface" Then
                Sheets("ACCUEIL").Cells(i, 16) = Mid(Sheets("TEMP").Cells(ligne, 1), 28)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 8) = "Géologie" Then
                Sheets("ACCUEIL").Cells(i, 17) = Mid(Sheets("TEMP").Cells(ligne, 1), 30)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 9) = "Typologie" Then
                Sheets("ACCUEIL").Cells(i, 18) = Mid(Sheets("TEMP").Cells(ligne, 1), 13)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 3) = "Age" Then
                Sheets("ACCUEIL").Cells(i, 19) = Mid(Sheets("TEMP").Cells(ligne, 1), 33)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 11) = "Morphologie" Then
                Sheets("ACCUEIL").Cells(i, 20) = Mid(Sheets("TEMP").Cells(ligne, 1), 15)
            ElseIf Left(Sheets("TEMP").Cells(ligne, 1), 10) = "Lithologie" Then
                Sheets("ACCUEIL").Cells(i, 21) = Mid(Sheets("TEMP").Cells(ligne, 1), 43)
            End If
        Next ligne
        Sheets("Temp").Cells.ClearContents
    Else
        Err.Clear
    End If
Next i
End Sub
0
maximegeomat Messages postés 1 Statut Membre
 
Merci gbinforme pour cette réponse rapide et ce script super efficace.

Sujet Résolue !!
0
gbinforme Messages postés 15481 Date d'inscription   Statut Contributeur Dernière intervention   4 728
 
Merci du retour et content de t'avoir aider à solutionner ton projet.
0

Discussions similaires

Recherche multi exp dans pokémon heart gold
tom -
Estebalignon -

6 réponses
Pokémon SoulSilver multi exp
Randy62 -
rieulebg -

8 réponses
2eme multi exp?
sohanejeff30 -
missing you -

1 réponse