Discussion :

[thomasaurelien]

Bonjour,
Je me permet de vous contacter pour avoir un avis sur mon code (possibilité d'amélioration)
De plus quand je remplis la zone de texte "zt_nomclub" sur les feuilles copiées j'ai un saut de ligne aucune idée d'où cela peux venir

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
 
Option Explicit
 
Const url = "https://www.ligue1.fr"
 
Function codehtmlpage(ByVal siteweb As String) As String
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", siteweb, False
        .send
        codehtmlpage = .responsetext
    End With
End Function
 
Sub recupclub()
    Dim elem As Object
    Dim mtableclub As Object, mtablecluba As Object, mtableclubdiv As Object, ele As Object, el As Object
    Dim clubs() As String
    Dim a As Integer, b As Integer
    With CreateObject("htmlfile")
        .body.innerhtml = codehtmlpage(url & "/clubs/liste")
        For Each elem In .all
            If elem.classname = "ClubListPage-list" Then
                Set mtableclub = elem
                Set mtableclubdiv = mtableclub.getElementsByclassname("card-body-title")
                Set mtablecluba = mtableclub.getElementsByTagName("a")
 
                For Each ele In mtableclubdiv
                    a = a + 1
                    ReDim Preserve clubs(1 To 2, 1 To a)
                    clubs(1, a) = ele.innertext
                    'MsgBox ele.innertext
                Next
                a = 0
                For Each el In mtablecluba
                    a = a + 1
                    clubs(2, a) = el.getAttribute("HREF")
                    'MsgBox el.getAttribute("HREF")
                Next
            End If
        Next
        'MsgBox clubs(1, 1) & " " & clubs(2, 1)
        'MsgBox clubs(1, 20) & " " & clubs(2, 20)
        For b = 1 To a
            Sheets("modeleclub").Select
            Sheets("modeleclub").Copy Before:=Sheets("modeleclub")
            Sheets(b + 1).Name = clubs(1, b)
            Sheets(b + 1).Shapes.Range(Array("zt_nomclub")).Select
            Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = clubs(1, b)
            Sheets(b + 1).Range("B6").FormulaR1C1 = Right(url & clubs(2, b), Len(url & clubs(2, b)) - 8) & ".fr"
        Next
    End With
End Sub

France.xlsm

[E KERGRESSE]

De plus quand je remplis la zone de texte "zt_nomclub" sur les feuilles copiées j'ai un saut de ligne aucune idée d'où cela peux venir ?

Bonjour,

A tester :

Le saut de ligne est dû au caractère Chr(13) présent dans la chaine récupérée. Dans le code, je transforme la chaine en tableau avec la fonction Split et je ne prends que la première cellule (il n'y en a pas d'autre du reste).
En guise d'amélioration, vous pourriez mettre directement un lien hypertexte dans vos onglets en B6.

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
 
Sub recupclub()
 
    Dim elem As Object
    Dim mtableclub As Object, mtablecluba As Object, mtableclubdiv As Object, ele As Object, el As Object
    Dim clubs() As String
    Dim a As Integer, b As Integer
    Dim ShModele As Worksheet, ShClub As Worksheet
 
 
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
 
 
    Set ShModele = Sheets("modeleclub")
 
    With CreateObject("htmlfile")
        .body.innerhtml = codehtmlpage(url & "/clubs/liste")
        For Each elem In .all
            If elem.classname = "ClubListPage-list" Then
                Set mtableclub = elem
                Set mtableclubdiv = mtableclub.getElementsByclassname("card-body-title")
                Set mtablecluba = mtableclub.getElementsByTagName("a")
 
                For Each ele In mtableclubdiv
                    a = a + 1
                    ReDim Preserve clubs(1 To 2, 1 To a)
                    clubs(1, a) = Split(ele.innertext, Chr(13))(0)
                Next
                a = 0
                For Each el In mtablecluba
                    a = a + 1
                    clubs(2, a) = el.getAttribute("HREF")
                Next
            End If
        Next
        For b = 1 To a
            ShModele.Copy Before:=Sheets(1)
            Set ShClub = Sheets(1)
            With ShClub
                 .Name = clubs(1, b)
                 .Shapes.Range(Array("zt_nomclub")).TextFrame2.TextRange.Characters.Text = clubs(1, b)
                 .Hyperlinks.Add Anchor:=.Range("B6"), Address:=url & clubs(2, b), TextToDisplay:=clubs(1, b)
            End With
            Set ShClub = Nothing
 
        Next
 
        Set ShModele = Nothing
    End With
 
    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With
 
    MsgBox "Fin de récupération !", vbInformation
 
End Sub

[thomasaurelien]

Merci pour ton aide et conseil E KERGRESSE

Je vais tester et améliorer tout cele.

[thomasaurelien]

Voila le code simplifié et optimisé (de 60 à 30 lignes) :

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
 
Sub recupclubs()
    Dim melem As Object, mele As Object, mtableclubs As Object
    Dim ShModele As Worksheet, ShClub As Worksheet
    Dim c As Integer
    With Application
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
    End With
    Set ShModele = Sheets("modeleclub")
    With CreateObject("htmlfile")
        .body.innerhtml = codehtmlpage(url & "/clubs/liste")
        For Each melem In .all
            If melem.classname = "ClubListPage-link" Then
                Set mtableclubs = melem
                c = c + 1
                For Each mele In mtableclubs.all
                    If mele.classname = "card-body-title" Then
                        MsgBox melem.getAttribute("HREF")
                        ShModele.Copy before:=ShModele
                        Set ShClub = Sheets(c + 1)
                        With ShClub
                            .Name = Split(mele.innertext, Chr(13))(0)
                            .Shapes.Range(Array("zt_nomclub")).TextFrame2.TextRange.Characters.Text = .Name
                            .Hyperlinks.Add Anchor:=.Range("B6"), Address:=url & melem.getAttribute("HREF"), TextToDisplay:=url & melem.getAttribute("HREF")
                        End With
                    End If
                Next
            End If
        Next
    End With
    With Application
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
    End With
End Sub

Je le poste si cela peut rendre service et coche "Résolu"