Macro récup données internet

**moteuv12** · 31/01/2015, 20h26

Bonsoir Le Forum,

Ci joint un fichier avec macro sans code malveillant, la premiere page est celle de téléchargement et traitement, la seconde stocke les données jour aprés jour.

Je n'arrive pas à résoudre le problème du changement de nom des pages ( mineur ) afin de faire une mise à jour globale. je m'explique.

Un jour l'adresse s'appelle " http://quinturf.blogspot.fr/2013/03/...i-25-mars.html "
le lendemain c'est " http://quinturf.blogspot.fr/2013/03/...manche-24.html "
puis un autre jour la date n'existera pas.

Malgré On Error je n'arrive pas à gérer un code automatique.

La macro en question s'appelle " quinturfblogspotfr ".

**SfJ5Rpw8** · 31/01/2015, 20h37

bonsoir,

on pourrais voir ce code ... utilise les balises [Code] [/code] pour le poster sur le forum et dis nous ou tu bloque ...

Fichier joint dans vos discussions

**moteuv12** · 31/01/2015, 20h41

Le voici

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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
Sub quinturfblogspotfr()
    Dim i As Long, Ligne As Long
     Dim cptr As Byte
Dim vUrl
 
' ---------------- traitement de la page avant-la-course.net  --------------------
 
'Application.Calculation = xlCalculationManual
'  Application.DisplayAlerts = False
' Application.ScreenUpdating = False
 
Ligne = 40
For Ligne = 40 To 708
 
    Sheets("quinturf.blogspot").Select
    jour = Range("A" & Ligne).Text
 
 
    Sheets("quinturf.blogspot.fr").Select
    Range("A1:Z50").ClearContents
 
    With ActiveSheet
        Range("X3").NumberFormat = "@"
 
 
    Range("X3").FormulaR1C1 = jour
    Range("X4").FormulaR1C1 = "=TEXT(R[-1]C,""jjjj"")"
    Range("X5").FormulaR1C1 = "=TEXT(R[-2]C,""mmmm"")"
    Range("Y5").FormulaR1C1 = "=TEXT(R[-2]C[-1],""mm"")"
    Range("X6").FormulaR1C1 = "=TEXT(R[-3]C,""aaaa"")"
    Range("X7").FormulaR1C1 = "=TEXT(R[-4]C,""j"")"
 
 
'       Range("X1").FormulaR1C1 = _
'       "=""http://quinturf.blogspot.fr/""&R[5]C&""/""&R[4]C[1]&""/pronostics-presse-quinte-""&R[3]C&""-""&R[6]C&"".html"""
 
    Range("X1").FormulaR1C1 = _
        "=""http://quinturf.blogspot.fr/""&R[5]C&""/""&R[4]C[1]&""/pronostics-presse-quinte-""&R[3]C&""-""&R[6]C&""-""&R[4]C&"".html"""
 
 
'    Range("X1").FormulaR1C1 = _
'        "=""http://quinturf.blogspot.fr/""&R[5]C&""/""&R[4]C[1]&""/pronostics-presse-quinte-""&R[3]C&""-""&R[6]C - 1&"".html"""
 
'    On Error Resume Next
 
    Range("X1").Copy
    Range("X1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
 
     With [X1]
        .Select
            vUrl = .Text
        End With
 
 
        With .QueryTables.Add(Connection:="URL;" & vUrl, Destination:=.Range("A1"))
            .Name = "quinturf.blogspot.fr"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingAll
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = True
            .WebDisableDateRecognition = True
            .WebDisableRedirections = True
            .Refresh BackgroundQuery:=False
DoEvents
        End With
        End With
 
    Columns("A:A").Select
    Selection.Replace What:=" - ", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    Selection.Replace What:=" : ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
'---------------------------
ActiveSheet.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
DoEvents
 
'    Range("A1").Select
'Cells.Find(What:="Non-partant", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
'ActiveCell.EntireRow.Delete
 
    Range("E8").Select
    ActiveCell.FormulaR1C1 = "=extraire_maj(RC[-4])"
    Range("F8").Select
    ActiveCell.FormulaR1C1 = "=extraire_num(RC[-5])"
 
    Range("E8:F8").Select
    Selection.AutoFill Destination:=Range("E8:F130"), Type:=xlFillDefault
 
    Range("G8").FormulaR1C1 = "=IF(RC[-1]="""",0,1)"
    Range("G8").Select
    Selection.AutoFill Destination:=Range("G8:G197"), Type:=xlFillDefault
 
    Range("G8:G197").Select
For Each cell In Selection
If cell.Value = 0 Then cell.EntireRow.Delete
Next cell
 
ActiveSheet.Columns(6).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
 
    Range("E1:E113").Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("E:E").Select
    Selection.Replace What:=" : ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
For Each cell In Columns("E:E").SpecialCells(xlCellTypeConstants, 23)
cell.Value = Trim(cell.Value)
Next
 
ActiveSheet.Columns(6).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
DoEvents
 
    Range("G1:G60").Select
For Each cell In Selection
 
If cell.Value = 0 Then cell.EntireRow.Delete
Next cell
 
    Range("G1:G60").Select
For Each cell In Selection
 
If cell.Value = 0 Then cell.EntireRow.Delete
Next cell
 
    Range("G1:G60").Select
For Each cell In Selection
 
If cell.Value = 0 Then cell.EntireRow.Delete
Next cell
 
    Columns("E:E").Select
    Selection.Replace What:=" .......", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
 
    Columns("G:G").ClearContents
 
 
'-----------------------------------------------------
 
    Range("A1").Select
Cells.Find(What:="Publié par Benoit Hugon", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
Range(ActiveCell, ActiveCell.End(xlDown)).EntireRow.Delete
 
Columns("E:E").Select
Call MakeUpperCase
 
'-----------------------------------------------------
 
 
 
 
 
 
    recette = Range("E1").End(xlDown).Row
'    On Error Resume Next
 
 
For i = 1 To recette
 Tablo = Split(Range("F" & i), Chr(46))
 For cptr = 0 To UBound(Tablo)
 
Cells(cptr + 2, 15) = Tablo(cptr)
 
 Next cptr
 
     Range("O2:O10").Select
For Each cell In Selection
If cell.Value = 0 Then cell.Delete Shift:=xlUp
Next cell
 
     Range("O2:O10").Select
For Each cell In Selection
If cell.Value = 0 Then cell.Delete Shift:=xlUp
Next cell
 
 
    Range("O2:O9").Copy
    Range("G" & i).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("O2:O10").ClearContents
 
     Range("N" & i).Select
If Range("N" & i).Value = "" And Range("A" & i).Value <> "" Then
Range("A" & i).EntireRow.Delete
    recette = recette - 1
End If
 Next i
 
' i = Range("H1").End(xlDown).Row
'Range("A" & i & ":A" & i + 3).EntireRow.Delete
 
Columns("F:F").Delete Shift:=xlToLeft
Columns("A:D").Delete Shift:=xlToLeft
Call Archiver(Ligne)
 
Next Ligne
 
 
    Range("A1").Select
 
 
' FIN de Traitement de la page quinturf.blogspot.fr
  Application.DisplayAlerts = True
 Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
End Sub

**moteuv12** · 01/02/2015, 08h38

Bonjour à Toutes et Tous,

C'est le début du code qui ne va pas avec le nom des pages de connexion qui change légèrement . Le mieux pour comprendre est d'utiliser le fichier joint.
Quelqu'un a une idée??

Macro récup données internet

Excel

Discussions similaires

Partager

Partager