Copier le contenu d'une table HTML dans une feuille Excel

**jeanmidudu** · 23/11/2015, 16h34

Bonjour à tous

,

Je suis actuellement sur un gros projet en VBA, pour lequel j'ai été bloqué à plusieurs reprises mais grâce aux différentes astuces trouvées sur ce forum, j'ai toujours pu m'en sortir.
Sauf que là j'ai beau chercher encore et encore, je ne trouve pas de solution à mon problème

:

Je dois accèder à une page web puis activer un onglet en javascript (jusqu'ici pas de problème), pour ensuite aller chercher les informations contenues dans un tableau HTML (le 9ème de la page). Il faut que seul le texte contenu dans les cellules du tableau soit recopié dans une nouvelle feuille Excel.
Je continue de chercher, mais je ne trouve rien qui corresponde à mon besoin, je m'en remet donc directement à vous.

Voici le code VBA (non fonctionnel pour la partie d'accès et de recopie, vous l'aurez compris) ainsi que le code qui m'intéresse de la page HTML :

Le code VBA :

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
Option Explicit
 
Private Sub InfoPJIAccueil_Click()
     Dim Okay As VbMsgBoxResult
    Okay = MsgBox("Vous êtes sur le point de retourner à l'accueil." & Chr(13) & "Toutes les informations seront perdues." _
                    & Chr(13) & "Etes-vous sur?", vbOKCancel + vbExclamation, "Retourner à l'accueil")
    If Okay = 1 Then
        Unload InfoPJI
        UserForm1.Show
    Else
        Exit Sub
    End If
End Sub
 
Private Sub RecherchePJI_Click()
    Dim LePJI As String
    LePJI = PJI.Value
    Call Rechercher(LePJI)
End Sub
 
'Fonction de recherche des informations des critères du PJI
Sub Rechercher(PJI)
    Dim IE As New InternetExplorer
    Dim IEDoc As HTMLDocument
    Dim TableHTML As HTMLTable
    Dim trBoucle As HTMLTableRow
    Dim cellBoucle As HTMLTableCell
    Dim i As Integer, j As Integer
 
    Set IE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
 
    IE.navigate "http://monsiteweb/recherche.do?method=rechercher&identifiant.identifiantPji=" & PJI 'Accéder à la page correspondant à la recherche du PJI
    IE.Visible = False
 
    Do Until IE.readyState = READYSTATE_COMPLETE 'Attente du chargement complet de la page web
        DoEvents
    Loop
 
    Set IEDoc = IE.document
    IE.document.all.Item
    Call IE.document.parentWindow.execScript("javascript:selectionner(31)", "JavaScript") 'accéder à l'onglet javascript du tableau des composants
 
    Do Until IE.readyState = READYSTATE_COMPLETE 'attente du chargement de la page
        DoEvents
    Loop
 
    Set TableHTML = IEDoc.getElementsByTagName("table")(9)
 
    i = 1
    j = 1
    For Each trBoucle In TableHTML
        For Each cellBoucle In trBoucle
            ThisWorkbook.Sheets(7).Range(i, j).Value = TableHTML.outerText
            i = i + 1
            j = j + 1
        Next
        End
    Next
    End
 
End Sub

Le code HTML :

Code html :

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
<div class="RnoSectionFree RnoSectionFirst"> 
	<div class="RnoSectionContent"> 
		<div class="RnoDataTable">
			<table><tr></tr>
 
					<tr>
 
					<td  onmouseout="return nd();" onmouseover="openCellTagCrit(
					'002',
					'001',
					'STANDA',
					'STANDARD                 ',
					'                    ',
					'5840');">
						STANDA
					</td>
 
					<td  onmouseout="return nd();" onmouseover="openCellTagCrit(
					'007',
					'A2S',
					'XFC   ',
					'FAMILLE XFC              ',
					'                    ',
					'1691');">
						XFC   
					</td>

Je précise que le code HTML est incomplet car très repetitive, je peux néanmoins ajouter qu'il s'agit du 9ème tableau de la page web.

Merci d'avance pour vos réponses!

Invité · 23/11/2015, 22h14

bonsoir,

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
#If VBA7 Then
 Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As Long
 Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
 Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#Else
 Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
 Private Declare Function CloseClipboard Lib "User32" () As Long
 Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
 Private Declare Function EmptyClipboard Lib "User32" () As Long
 Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#End If
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
 
 
Sub test()
 
Dim txt As String
txt = " <table> <tr> <td  onmouseout=""return nd();"" onmouseover=""openCellTagCrit('002','001','STANDA','STANDARD','','5840');"">STANDA</td> <td  onmouseout="" nd();"" onmouseover=""openCellTagCrit('007','A2S','XFC   ','FAMILLE XFC              ','                    ','1691');"">XFC   </td></tr></table>"
ClipBoard_SetData txt
ActiveCell.PasteSpecial xlPasteAll
End Sub
Function ClipBoard_GetData() As String
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)
 
   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
 
   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
 
   ' Clear the Clipboard.
   X = EmptyClipboard()
 
   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 
   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If
 
   End Function

**jeanmidudu** · 24/11/2015, 08h26

Bonjour,

Merci pour la réponse, mais ce n'est pas ce que je demande.
La question en très simplifié :
Comment recopier mon le contenu de mon tableau HTML dans une page feuille excel non ouverte? En langage VBA.

Je pensais utilser une boucle FOR EACH qui irait chercher chaque élément du tableau HTML et le recopier dans la cellule suivante d'une nouvelle feuille excel.
Merci d'avance.

**jeanmidudu** · 24/11/2015, 10h06

J'ai presque trouvé, le problème maintenant c'est de faire en sorte que de récupérer le tableau qui se trouve dans mon onglet JavaScript.
J'arrive à faire soit l'un (Récupérer le tableau dans la page courante) soit l'autre (Ouvrir l'onglet JavaScript) mais pas les deux en même temps.

Voici le code qui me permet de récupérer le tableau (il y a dedans des tentatives d'accès à l'onglet JavaScript, mais qui n'ont aucun effet.

Merci d'avance pour votre aide.
Code :

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
 
Sub test(PJI)
    Dim oDom As Object
    Dim IE As New InternetExplorer
    Dim IEDoc As HTMLDocument
    Dim x As Long, y As Long
    Dim myURL As String
    Dim oRow As Object, oCell As Object
    Dim data() As String
 
    Set IE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
    myURL = "http://mapageweb.fr/PSFV/CONSVEHI/recherche.do?method=rechercher&identifiant.identifiantPji=" & PJI
    IE.navigate myURL 'Accéder à la page correspondant à la recherche du PJI
    IE.Visible = False
 
    Do Until IE.readyState = READYSTATE_COMPLETE 'Attente du chargement complet de la page web
        DoEvents
    Loop
 
    Set IEDoc = IE.document
    IE.document.all.Item
    Call IE.document.parentWindow.execScript("javascript:selectionner(31)", "JavaScript") 'accéder à l'onglet javascript du tableau des composants
 
    Do Until IE.readyState = READYSTATE_COMPLETE 'attente du chargement de la page
        DoEvents
    Loop
 
    y = 1
    x = 1
    Set oDom = CreateObject("htmlFile")
    Call IE.document.parentWindow.execScript("javascript:selectionner(31)", "JavaScript")
    '''''''''''''''''''''''''
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", myURL, False
        Call IE.document.parentWindow.execScript("javascript:selectionner(31)", "JavaScript")
        .send
        Call IE.document.parentWindow.execScript("javascript:selectionner(31)", "JavaScript")
        oDom.body.innerHTML = .responseText
    End With
 
    With oDom.getElementsByTagName("table")(9)
        ReDim data(1 To .Rows.Length, 1 To .Cells.Length)
        For Each oRow In .Rows
            For Each oCell In oRow.Cells
                data(x, y) = oCell.innerText
                y = y + 1
            Next oCell
            y = 1
            x = x + 1
        Next oRow
    End With
 
    ThisWorkbook.Sheets(7).Cells(1, 1).Resize(UBound(data), UBound(data, 2)).Value = data
End Sub

Invité · 24/11/2015, 10h23

Envoyé par jeanmidudu

Bonjour,

Merci pour la réponse, mais ce n'est pas ce que je demande.
La question en très simplifié :
Comment recopier mon le contenu de mon tableau HTML dans une page feuille excel non ouverte? En langage VBA.

Je pensais utilser une boucle FOR EACH qui irait chercher chaque élément du tableau HTML et le recopier dans la cellule suivante d'une nouvelle feuille excel.
Merci d'avance.

bonjour,
c'est exactement ce que je te proposé! accorde toi au moins le temps te tester ce que je t'es donné!

Code Copie colle HTML :

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

1
2
3
4
5
6
7
Sub test()
 
Dim txt As String
txt = " <table> <tr> <td  onmouseout=""return nd();"" onmouseover=""openCellTagCrit('002','001','STANDA','STANDARD','','5840');"">STANDA</td> <td  onmouseout="" nd();"" onmouseover=""openCellTagCrit('007','A2S','XFC   ','FAMILLE XFC              ','                    ','1691');"">XFC   </td></tr></table>"
ClipBoard_SetData txt
ActiveCell.PasteSpecial xlPasteAll
End Sub

**jeanmidudu** · 24/11/2015, 10h32

Hélas ça ne fonctionne pas. Ton code ne permet pas l'accès à l'élément créé en JavaScript. Il me retourne unique le tableau HTML original.

Invité · 24/11/2015, 10h48

et ça ce n'est pas de l'HTML?

Code :

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

txt=oDom.getElementsByTagName("table")(9)

Copier le contenu d'une table HTML dans une feuille Excel [Toutes versions]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager