Moderatori: Anthony47, Flash30005
Option Base 1
Public objIE As Object
Public a As Variant
Public url As String
Public linkpb(500, 15) As String
Public p(12, 6) As Variant
Public ck(6, 500) As Variant
Public rif, rifrif, fine, inizio As Variant
Public d(12)
Sub estrailinkpb()
userform1.Show vbModeless
DoEvents
inizio = Timer1
myDate = Int(Now())
url = "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=" & Day(myDate) _
& "&dm=" & Month(myDate) & "&dy=" & Year(myDate) & "&df=1&dw=3"
Naviga (url)
Range("B9:R1000").ClearContents
parametri
destinazioni
numero = quanteVolte(a, "tbl_") / 19
rifrif = 0
For link = 1 To numero ' Sheets("prelievo").Cells(2, 5).Value
For data = 1 To 12
ck(2, link) = InStr(rifrif + 1, a, p(data, 2))
ck(3, link) = InStr(ck(2, link), a, p(data, 3)) + p(data, 5)
ck(4, link) = InStr(ck(3, link), a, p(data, 4))
linkpb(link, data) = Mid(a, ck(3, link), ck(4, link) - ck(3, link))
rifrif = ck(4, link)
If linkpb(link, data) = " " Then
linkpb(link, data) = ""
End If
If data = 12 Then
linkpb(link, data) = Format(linkpb(link, data), Standard)
End If
Sheets("prelievo").Cells(link + 8, d(data)).Value = linkpb(link, data)
Next data
Next link
'--metto i numeri e adatto la larghezza--------
Range("CA9:CA1400").Copy
Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A7").Select
Rows("9:1000").Select
Selection.RowHeight = 15
Range("A8").Select
'-------------------------------------------------
selezionate
ActiveWindow.DisplayGridlines = False
Unload userform1
fine = Timer1 '2
MsgBox ("Tempo impiegato " & Int((fine - inizio) / 60) & " min " & (fine - inizio) Mod 60 & " Sec")
End Sub
Function quanteVolte(str1, str2)
Dim strArray
strArray = Split(str1, str2)
quanteVolte = UBound(strArray)
End Function
Sub selezionate()
For ckb = 6 To 65000
sel1 = Sheets("studio & info").Cells(ckb, 3).Value
If sel1 = "" Then
inizio = ckb - 1
ckb = 65000
End If
Next ckb
For i = 1 To 1000
sel = Sheets("prelievo").Cells(8 + i, 21).Value
If sel <> "" Then
For ii = 1 To 12
Sheets("studio & info").Cells(i + inizio, d(ii) + 1).Value = Sheets("prelievo").Cells(sel + 8, d(ii)).Value
Next ii
Else
i = 1000
End If
Next i
End Sub
Sub parametri()
v = 1
p(v, 2) = "tbl_black_n_"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
End Sub
Sub Naviga(url)
a = ""
On Error Resume Next
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = False
objIE.Navigate url
c1 = Time
Do While objIE.busy
DoEvents
If Time > c1 + TimeValue("00:00:30") Then Exit Do
Loop 'opzionale, loop se non completato
a = objIE.document.body.innerHTML
'Range("a1").Value = a
b = Len(a)
Resume
closeIE
If a = "" Then
closeIE
Naviga (url)
End If
If Len(a) < 2500 Then
closeIE
Application.Wait Now + TimeValue("00:01:00")
Naviga (url)
End If
End Sub
Sub closeIE()
On Error Resume Next
objIE.Quit
Set objIE = Nothing
End Sub
Sub destinazioni()
d(1) = 1
d(2) = 2
d(3) = 5
d(4) = 6
d(5) = 8
d(6) = 9
d(7) = 11
d(8) = 13
d(9) = 15
d(10) = 16
d(11) = 17
d(12) = 18
End Sub
raimea ha scritto:ciao
grazie a gigi_ ho una macro che mi preleva dati , li mette in fgl prelievo , e mi copia solo alcune partite in fgl studio , ad ogni prelievo.
in col U9 , in giu' scrivo il numero delle partite da "studiare" e me le ritrovo gia in fgl studio.
- Codice: Seleziona tutto
Option Base 1
Public objIE As Object
Public a As Variant
Public url As String
Public linkpb(500, 15) As String
Public p(12, 6) As Variant
Public ck(6, 500) As Variant
Public rif, rifrif, fine, inizio As Variant
Public d(12)
Sub estrailinkpb()
userform1.Show vbModeless
DoEvents
inizio = Timer1
myDate = Int(Now())
url = "http://www.betonews.com/table.asp?tp=2001&lang=en&dd=" & Day(myDate) _
& "&dm=" & Month(myDate) & "&dy=" & Year(myDate) & "&df=1&dw=3"
Naviga (url)
Range("B9:R1000").ClearContents
parametri
destinazioni
numero = quanteVolte(a, "tbl_") / 19
rifrif = 0
For link = 1 To numero ' Sheets("prelievo").Cells(2, 5).Value
For data = 1 To 12
ck(2, link) = InStr(rifrif + 1, a, p(data, 2))
ck(3, link) = InStr(ck(2, link), a, p(data, 3)) + p(data, 5)
ck(4, link) = InStr(ck(3, link), a, p(data, 4))
linkpb(link, data) = Mid(a, ck(3, link), ck(4, link) - ck(3, link))
rifrif = ck(4, link)
If linkpb(link, data) = " " Then
linkpb(link, data) = ""
End If
If data = 12 Then
linkpb(link, data) = Format(linkpb(link, data), Standard)
End If
Sheets("prelievo").Cells(link + 8, d(data)).Value = linkpb(link, data)
Next data
Next link
'--metto i numeri e adatto la larghezza--------
Range("CA9:CA1400").Copy
Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A7").Select
Rows("9:1000").Select
Selection.RowHeight = 15
Range("A8").Select
'-------------------------------------------------
selezionate
ActiveWindow.DisplayGridlines = False
Unload userform1
fine = Timer1 '2
MsgBox ("Tempo impiegato " & Int((fine - inizio) / 60) & " min " & (fine - inizio) Mod 60 & " Sec")
End Sub
Function quanteVolte(str1, str2)
Dim strArray
strArray = Split(str1, str2)
quanteVolte = UBound(strArray)
End Function
Sub selezionate()
For ckb = 6 To 65000
sel1 = Sheets("studio & info").Cells(ckb, 3).Value
If sel1 = "" Then
inizio = ckb - 1
ckb = 65000
End If
Next ckb
For i = 1 To 1000
sel = Sheets("prelievo").Cells(8 + i, 21).Value
If sel <> "" Then
For ii = 1 To 12
Sheets("studio & info").Cells(i + inizio, d(ii) + 1).Value = Sheets("prelievo").Cells(sel + 8, d(ii)).Value
Next ii
Else
i = 1000
End If
Next i
End Sub
Sub parametri()
v = 1
p(v, 2) = "tbl_black_n_"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "noWrap"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title="
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "right"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
v = v + 1
p(v, 2) = "title"
p(v, 3) = ">"
p(v, 4) = "<"
p(v, 5) = 1
End Sub
Sub Naviga(url)
a = ""
On Error Resume Next
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = False
objIE.Navigate url
c1 = Time
Do While objIE.busy
DoEvents
If Time > c1 + TimeValue("00:00:30") Then Exit Do
Loop 'opzionale, loop se non completato
a = objIE.document.body.innerHTML
'Range("a1").Value = a
b = Len(a)
Resume
closeIE
If a = "" Then
closeIE
Naviga (url)
End If
If Len(a) < 2500 Then
closeIE
Application.Wait Now + TimeValue("00:01:00")
Naviga (url)
End If
End Sub
Sub closeIE()
On Error Resume Next
objIE.Quit
Set objIE = Nothing
End Sub
Sub destinazioni()
d(1) = 1
d(2) = 2
d(3) = 5
d(4) = 6
d(5) = 8
d(6) = 9
d(7) = 11
d(8) = 13
d(9) = 15
d(10) = 16
d(11) = 17
d(12) = 18
End Sub
ciao
AntonioPatella ha scritto:raimea nn riesco a vedere l'allegato...
Public WithEvents qt As QueryTable
Private Sub qt_AfterRefresh(ByVal Success As Boolean)
If Not Success Then Exit Sub
Dim LastSh2 As Long
'
LastSh2 = Sheets("Foglio2").Cells(Rows.Count, 2).End(xlUp).Row
'
With Sheets("Foglio2").Cells(LastSh2 + 3, 2)
.Value = Now()
.Interior.ColorIndex = 4
.Font.Bold = True
End With
With Sheets("Foglio1")
.Range("$Z$1:$AB$1000").AutoFilter Field:=1, Criteria1:=">=0"
.Range("$Z$1:$AB$1000").AutoFilter Field:=3, Criteria1:=">=0"
.Range("A2:AB1000").SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("Foglio2").Cells(LastSh2 + 4, 1)
End With
'Beep
'Foglio2.Range("AD1").Value = Foglio2.Range("AD1").Value + 1
End Sub
Private Sub Worksheet_Activate()
Set qt = Nothing
DoEvents
Set qt = Sheets("Foglio1").Range("B2").QueryTable
End Sub
Torna a Applicazioni Office Windows
Inserire dati filtrati da 2 file ad un terzo file Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 14 |
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
Visitano il forum: Nessuno e 42 ospiti