macro 2003 ne fonctionne plus sous 2016

**irne6381** · 21/07/2019, 18h06

Bonjour, Je ne suis pas un pro de vba! j'avais récupéré une macro pour récupérer des données d'internet.
Celle-ci ne fonctionne plus sous 2016
voici la partie de macro (j'ai variabilisé l'url)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
   With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;http://www.rugbycoaching.eu/joueurs.php?poste=" + Tab_Place(Place) + "&club=all&journee=all&tri=points&from=" + Debut + "&to=" + Fin + "" _
                , Destination:=Range("A1"))
                .Name = _
                "joueurs.php?poste=" + Tab_Place(Place) + "&club=all&journee=all&tri=points&from=" + Debut + "&to=" + Fin + ""
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = False
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingAll
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With

en 2016, dès .Refresh BackgroundQuery:=False j'ai une erreur inconnue
j'ai réessayé de refaire une macro 2016 (récupéré des données) mais je ne peux pas variabiliser, et je ne peux détruire les queries

**patricktoulon** · 21/07/2019, 18h23

re
bonjour

déjà pour la concaténation d'une chaine utilise le caractère de jonction(&) et non le (+) ca passera mieux peut être

teste ceci dans un fichier vierge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim Tab_Place(10)
Tab_Place(1) = "all"
debut = 1
fin = 40
place = 1
With ActiveSheet.QueryTables.Add(Connection:= _
 "URL;http://www.rugbycoaching.eu/joueurs.php?poste=" & Tab_Place(place) & "&club=all&journee=all&tri=points&from=" & debut & "&to=" & fin & "" _
 , Destination:=Range("A1"))
 .Name = _
 "joueurs.php?poste=" & Tab_Place(place) & "&club=all&journee=all&tri=points&from=" & debut & "&to=" & fin & ""
 .FieldNames = True
 .RowNumbers = False
 .FillAdjacentFormulas = False
 .PreserveFormatting = False
 .RefreshOnFileOpen = False
 .BackgroundQuery = True
 .RefreshStyle = xlInsertDeleteCells
 .SavePassword = False
 .SaveData = True
 .AdjustColumnWidth = True
 .RefreshPeriod = 0
 .WebSelectionType = xlEntirePage
 .WebFormatting = xlWebFormattingAll
 .WebPreFormattedTextToColumns = True
 .WebConsecutiveDelimitersAsOne = True
 .WebSingleBlockTextImport = False
 .WebDisableDateRecognition = False
 .WebDisableRedirections = False
 .Refresh BackgroundQuery:=False
 End With
End Sub

**irne6381** · 21/07/2019, 18h38

à laquelle je ne m'y attendais pas aussitôt.
çà n'a rien changé je m'y attendais un peu.
je donne la boucle entière pour ne pas s'y perdre en gros, comme tu es de Toulon tu devrais connaitre ce site traitant du rugby (ou pas)
il s'agit de récupérer place par place tous les joueurs qui y sont affectés ou en polyvalence.
En Office 2003 pas de problème,
en office 2016

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    Dim Place As Integer
    Rem commencer la boucle place
    Dim FinDePage As Boolean
    Dim Tab_Place(10) As String
    Tab_Place(1) = "Pilier"
    Tab_Place(2) = "Talonneur"
    Tab_Place(3) = "2%E8me%20ligne"
    Tab_Place(4) = "3%E8me%20ligne"
    Tab_Place(5) = "Demi%20de%20m%EAl%E9e"
    Tab_Place(6) = "Ouvreur"
    Tab_Place(7) = "Ailier"
    Tab_Place(8) = "Centre"
    Tab_Place(9) = "Arri%E8re"
    Tab_Place(10) = "all"
    Dim Debut As String
    Dim Increment As String
    Increment = "40"
    Sheets("Ref").Select
    Cells.Select
    Selection.ClearContents
    For Place = 1 To 9
        Rem tant que l'on récupère 40 joueurs
        FinDePage = False
        Debut = "1"
        Fin = LTrim(Val(Debut) + Val(Increment) - 1)
        While FinDePage = False
            Rem effacer la feuille 1
            Sheets("Travail").Select
            Cells.Select
            Selection.Delete Shift:=xlUp
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;http://www.rugbycoaching.eu/joueurs.php?poste=" & Tab_Place(Place) & "&club=all&journee=all&tri=points&from=" & Debut & "&to=" & Fin & "" _
                , Destination:=Range("A1"))
                .Name = _
                "joueurs.php?poste=" & Tab_Place(Place) & "&club=all&journee=all&tri=points&from=" & Debut & "&to=" & Fin & ""
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = False
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingAll
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
            Range("A1").Select
            Cells.Find(What:="#", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                True, SearchFormat:=False).Activate
            ActiveCell.Offset(1, 0).Select
            Rem vérifier le cas ou cellule vide
            Range(Selection, Selection.End(xlDown)).Select
            nombre = Selection.Cells.Count
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
 
            Sheets("Ref").Select
            ActiveSheet.Cells(Val(Debut), (Place - 1) * 6 + 1).Select
            ActiveSheet.Paste
            If nombre = 40 Then
                Debut = LTrim(Val(Fin) + 1)
                Fin = LTrim(Val(Debut) + Val(Increment) - 1)
            Else
                FinDePage = True
            End If
        Wend
    Next Place

erreur d'exécution 1004
une erreur inattendue s'est produite

**patricktoulon** · 21/07/2019, 21h38

re
écoute je viens de le tester avec 2007 et 2013 ca fonctionne
il y a quelques ratés au niveau de la récup de certains tableaux (puisqu'il y a des blanc) mais sinon le query fonctionne
et surtout si tu est sensé le faire régulièrement fait un .delete de ton query sinon ca alourdi le fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Sub test()
Application.ScreenUpdating = fase
Dim Place As Integer
    Rem commencer la boucle place
    Dim FinDePage As Boolean
    Dim Tab_Place(10) As String
    Tab_Place(1) = "Pilier"
    Tab_Place(2) = "Talonneur"
    Tab_Place(3) = "2%E8me%20ligne"
    Tab_Place(4) = "3%E8me%20ligne"
    Tab_Place(5) = "Demi%20de%20m%EAl%E9e"
    Tab_Place(6) = "Ouvreur"
    Tab_Place(7) = "Ailier"
    Tab_Place(8) = "Centre"
    Tab_Place(9) = "Arri%E8re"
    Tab_Place(10) = "all"
    Dim Debut As String
    Dim Increment As String
    Increment = "40"
    Sheets("Ref").Cells.ClearContents
    For Place = 1 To 9
        Rem tant que l'on récupère 40 joueurs
        FinDePage = False
        Debut = "1"
        Fin = LTrim(Val(Debut) + Val(Increment) - 1)
        While FinDePage = False
            Rem effacer la feuille 1
            Sheets("Travail").Select
            Cells.Delete Shift:=xlUp
            With ActiveSheet.QueryTables.Add(Connection:= _
                "URL;http://www.rugbycoaching.eu/joueurs.php?poste=" & Tab_Place(Place) & "&club=all&journee=all&tri=points&from=" & Debut & "&to=" & Fin & "" _
                , Destination:=Range("A1"))
                .Name = _
                "joueurs.php?poste=" & Tab_Place(Place) & "&club=all&journee=all&tri=points&from=" & Debut & "&to=" & Fin & ""
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = False
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlEntirePage
                .WebFormatting = xlWebFormattingAll
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            .Delete
            End With
            Range("A1").Select
            Cells.Find(What:="#", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
                :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                True, SearchFormat:=False).Activate
            ActiveCell.Offset(1, 0).Select
            Rem vérifier le cas ou cellule vide
            Range(Selection, Selection.End(xlDown)).Select
            nombre = Selection.Cells.Count
            Range(Selection, Selection.End(xlToRight)).Select
            Selection.Copy
 
            Sheets("Ref").Select
            ActiveSheet.Cells(Val(Debut), (Place - 1) * 6 + 1).Select
            ActiveSheet.Paste
            If nombre = 40 Then
                Debut = LTrim(Val(Fin) + 1)
                Fin = LTrim(Val(Debut) + Val(Increment) - 1)
            Else
                FinDePage = True
            End If
        Wend
    Next Place
End Sub

et non j'e connais pas le rudby c'est pas ma tasse de thé

**patricktoulon** · 21/07/2019, 22h42

re
fait moi plaisir sort des sentiers battus et teste ca dans un fichier vierge

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
Sub testX()
    Dim p, I&
   Sheets(1).Cells.Clear
    p = Array("Pilier", "Talonneur", "2%E8me%20ligne", "3%E8me%20ligne", "Demi%20de%20m%EAl%E9e", "Ouvreur", "Ailier", "Centre", "Arri%E8re", "all")
    For I = 0 To UBound(p)
        getTable p(I), 1, 40
    Next
End Sub
Sub getTable(place, debut, fin)
    Application.ScreenUpdating = False
    Dim Req As Object, url As String, Tables, T, elem
    'http://www.rugbycoaching.eu/joueurs.php?poste=" & Tab_Place(place) & "&club=all&journee=all&tri=points&from=" & debut & "&to=" & fin
    url = "http://www.rugbycoaching.eu/joueurs.php?poste=" & place & "&club=all&journee=all&tri=points&from=1&to=40"
    Set Req = CreateObject("microsoft.xmlhttp")
    Req.Open "GET", url, False
    Req.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko"
    Req.SetRequestHeader "Cache-Control", "no-cache"
    Req.send
    With CreateObject("htmlfile")
        .body.innerhtml = Req.responsetext
        Set Tables = .getelementsbytagname("TABLE")
        Set T = Tables(5)
        For Each elem In T.all
            If elem.tagname = "IMG" Then elem.parentelement.RemoveChild (elem)
        Next
        If .parentWindow.clipboardData.setData("Text", "<html><body><font color=#ff0000 size=6><strong>" & place & "</strong></font><br>" & T.outerhtml & "</body></html>") Then
            Application.ScreenUpdating = False
            With Sheets(1)
                .Activate
                .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
                .Paste
            End With
            .parentWindow.clipboardData.clearData "Text"
        End If
    End With
End Sub

**irne6381** · 22/07/2019, 11h06

Je n'ai pas 2016 au boulot, je testerai çà de chez moi
merci en tous cas

macro 2003 ne fonctionne plus sous 2016 [XL-2016]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager