Bonjour,
Je récupère en VBA via la méthode Workbooks.Open(monUrl) le contenu d'une page Html.
Pour en récupérer plusieurs, je fais une boucle pour récupérer itérativement l'ensemble des données dont j'ai besoin.
Mon problème est qu'à partir d'un certain point (j'ai l'impression aléatoirement) la méthode Open plante et j'ai :
* Soit Excel qui plante complètement (page blanche, puis Excel se ferme entièrement)
* Soit le message d'erreur "La méthode Workbooks.Open a echoué" ou Impossible d'ouvrir
www.google.fr
J'ai trouvé un post expliquant qu'Excel posait problème à ce niveau là : http://support2.microsoft.com/kb/210684/fr#survey
Mais malgré le fait de fermer le classeur puis de le rouvrir, pas moyen de récupérer l'ensemble des informations des pages !
Vous avez une idée pour contourner ça ?
Ci-dessous le code VBA que j'utilise (fichier TestCopieIndex_Baremes_memeOnglet.xlsm) :
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
| Sub CopySheetTest()
Dim iTemp As Integer
Dim oBook As Workbook
Dim oBookTemp As Workbook
Dim iCounter As Integer
Dim nbLinges As Long
Dim ligne As Long
' Create a new blank workbook:
iTemp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set oBook = Application.Workbooks.Add
' Save the workbook:
oBook.SaveAs "C:\Users\MERTZJL\testRecup_memeOnglet2.xlsx"
' Copy the sheet in a loop. Eventually, you get error 1004: Copy Method of Worksheet class failed.
For iCounter = 1 To 100
Set oBookTemp = Application.Workbooks.Open("http://www.google.fr")
'On supprime également la petite image et on met en forme
For Each monImage In oBookTemp.Worksheets(1).Shapes
monImage.Delete
Next monImage
For Each monLien In oBookTemp.Worksheets(1).Hyperlinks
monLien.Delete
Next monLien
oBookTemp.Worksheets(1).Copy After:=oBook.Worksheets(1)
oBookTemp.Close SaveChanges:=False
'Copie de la zone délimitée par ce nombre de lignes
nbLignes = oBook.Worksheets(2).Range("A100000").End(xlUp).Row
oBook.Worksheets(2).Range("A1:A" & nbLignes).EntireRow.Copy
'On le colle dans l'onglet correspondant dans le fichier principal
ligne = oBook.Worksheets(1).Range("A1000000").End(xlUp).Row + 4
oBook.Worksheets(1).Range("A" & ligne).PasteSpecial xlPasteAll
oBook.Worksheets(1).Range("A" & ligne & ":A" & ligne + 1).EntireRow.Delete
Application.DisplayAlerts = False
oBook.Worksheets(2).Delete
Application.DisplayAlerts = True
'Uncomment this code for the workaround:
'Save, close, and reopen after every 100 iterations:
If iCounter Mod 20 = 0 Then
oBook.Close SaveChanges:=True
Set oBook = Nothing
Set oBook = Application.Workbooks.Open("C:\Users\MERTZJL\testRecup_memeOnglet2.xlsx")
End If
Next
End Sub |
J'ai essayé de faire la même chose sans concaténer mes informations dans le même onglet et étrangement ça passe (fichier TestCopieIndex_Baremes.xlsm) :
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
| Sub CopySheetTest()
Dim iTemp As Integer
Dim oBook As Workbook
Dim oBookTemp As Workbook
Dim iCounter As Integer
Dim nbLinges As Long
Dim ligne As Long
' Create a new blank workbook:
iTemp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set oBook = Application.Workbooks.Add
Application.SheetsInNewWorkbook = iTemp
' Save the workbook:
oBook.SaveAs "C:\Users\MERTZJL\testRecup_memeOnglet.xlsx"
' Copy the sheet in a loop. Eventually, you get error 1004: Copy Method of Worksheet class failed.
For iCounter = 1 To 100
Set oBookTemp = Application.Workbooks.Open("http://www.google.fr")
'On supprime également la petite image et on met en forme
For Each monImage In oBookTemp.Worksheets(1).Shapes
monImage.Delete
Next monImage
For Each monLien In oBookTemp.Worksheets(1).Hyperlinks
monLien.Delete
Next monLien
Application.SheetsInNewWorkbook = iTemp
oBookTemp.Worksheets(1).Copy After:=oBook.Worksheets(1)
oBookTemp.Close SaveChanges:=False
'Uncomment this code for the workaround:
'Save, close, and reopen after every 100 iterations:
If iCounter Mod 20 = 0 Then
oBook.Close SaveChanges:=True
Set oBook = Nothing
Set oBook = Application.Workbooks.Open("C:\Users\MERTZJL\testRecup_memeOnglet.xlsx")
End If
Next
End Sub |
Merci.
Partager