ai ragione
ciao
Moderatori: Anthony47, Flash30005
For RR = Riga to 1 step - 1
....
'fai quello che devi fare
...
Next RR
Sub RitAttCol2()
Dim Vc(10) As String
Application.ScreenUpdating = False
Application.Calculation = xlManual
ur = Worksheets("statistiche").Range("f50")
Sheets("Archivio UK49s").Select
urk = Range("K" & Rows.Count).End(xlUp).Row
for ur = urk
For VV = 1 To 7
ContaR = 0
Vc(VV) = Sheets("Statistiche").Range("F" & 51 + VV).Text
For RR = urk To 3 Step -1
ContaR = urk - RR
If Range("K" & RR).Text = Vc(VV) Then
Sheets("Statistiche").Range("G" & 51 + VV).Value = ContaR
GoTo SaltaVV
End If
Next RR
SaltaVV:
Next VV
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub raicols()
aaaaa = Timer
Dim Estraz, EData, ListaCol, I As Long, J As Long, DelAr(), TabCol As String
Dim cCol As String, bDateI As Long, eDateI As Long, cDel As Long, Del As Long
Dim bMax As Long, eMax As Long
TabCol = "AJ16:AJ22" '<< Tabella colori su Statistiche
ListaCol = Foglio14.Range(TabCol)
Estraz = Foglio21.Range("K3:K" & Cells(Rows.Count, "K").End(xlUp).Row)
EData = Foglio21.Range("B3:B" & Cells(Rows.Count, "K").End(xlUp).Row)
For I = LBound(ListaCol, 1) To UBound(ListaCol, 1)
Del = 0: ReDim DelAr(3, UBound(Estraz, 1))
cCol = ListaCol(I, 1): bDateI = LBound(EData, 1): eDateI = 99999
For J = LBound(Estraz, 1) To UBound(Estraz, 1)
If Estraz(J, 1) = cCol Then
cDel = J - bDateI - 1
If cDel > Del Then
Del = cDel: bMax = bDateI: eMax = J
End If
bDateI = J
End If
Next J
'Compila risultati
sdata = Split(EData(bMax, 1), "/"): Foglio14.Range(TabCol).Range("A1").Offset(Ciclo, -1).Value = DateSerial(sdata(2), sdata(1), sdata(0))
Foglio14.Range(TabCol).Range("A1").Offset(Ciclo, 1).Value = Del
sdata = Split(EData(eMax, 1), "/"): Foglio14.Range(TabCol).Range("A1").Offset(Ciclo, 2).Value = DateSerial(sdata(2), sdata(1), sdata(0))
Ciclo = Ciclo + 1
Next I
MsgBox (Timer - aaaaa)
End Sub
Sub Ritardo()
Dim Area As Range
Dim UltK As Long
Dim Ritardo As Integer
Dim CL As Range
Dim X As Integer
Dim Cella As Range
Dim Colori As Range
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Set WS1 = ThisWorkbook.Sheets("Archivio_UK49s")
Set WS2 = ThisWorkbook.Sheets("Statistiche")
userform1.Show vbModeless '1
DoEvents
Inizio = Timer
Worksheets("statistiche").Unprotect ' togli protez
Worksheets("archivio_uk49s").Unprotect ' togli protez
UltK = WS1.Range("K" & Rows.Count).End(xlUp).Row
Set Area = WS1.Range("K3:K" & UltK)
Application.ScreenUpdating = False
Set Colori = WS2.Range("AJ16:Aj22") ' qui fgl statistiche, ci deveno essere i 7 colori da cercare/confrontare
Colori.Offset(0, 1).Resize(, 2) = ClearContents
Colori.Offset(0, -1).Resize(, 1) = ClearContents
With WS1
For Each Cella In Colori
Ritardo = 0
For Each CL In Area
If CStr(CL) <> CStr(Cella) Then
Ritardo = Ritardo + 1
Else
If Ritardo <> 0 And Ritardo > CInt(Cella.Offset(0, 1)) Then
Cella.Offset(0, -1) = CDate(CL.Offset(-Ritardo, -9))
Cella.Offset(0, 1) = Ritardo
Cella.Offset(0, 2) = CDate(CL.Offset(0, -9))
End If
Ritardo = 0
End If
Next CL
Next Cella
End With
Application.ScreenUpdating = True
Set Cella = Nothing
Set Area = Nothing
Set WS1 = Nothing
Set WS2 = Nothing
Set Colori = Nothing
Range("AI15:AL22").Select 'metto in ordine decrescente
Selection.Copy
Range("AI24").Select
ActiveSheet.Paste
Range("AI25:AL31").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("AK25"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("AG24").Select
ActiveWindow.DisplayGridlines = False 'metti protez e nascondi griglia
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True
Unload userform1 '2
Fine = Timer
MsgBox ("Tempo impiegato " & Int((Fine - Inizio) / 60) & " min " & (Fine - Inizio) Mod 60 & " Sec")
End Sub
Sub AggUK49()
Worksheets("Appoggio").Select
userform1.Show vbModeless
DoEvents
Worksheets("appoggio").Unprotect ' togli protez
Range("A1:I65").Select ' cancello il contenuto precedente
Selection.ClearContents
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http:www.mondobet.net/lotto/lotto-49s", Destination:=Range( _
"$A$1"))
.Name = "?page_id=108"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A2:H52").Select ' ordino dal piu vecchio al piu recente
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("O2").Select
Unload userform1
End Sub
'.WebSelectionType = xlEntirePage 'Trovi una riga cosi'; eliminala...
.WebSelectionType = xlSpecifiedTables ' .. e sostituisci con questa
.WebTables = "4" '<< Subito dopo aggiungere l' indice di tabella
'Continuare con le istruzioni registrate
Sub AggUK49()
Worksheets("Appoggio").Select
userform1.Show vbModeless
DoEvents
Worksheets("appoggio").Unprotect ' togli protez
Range("A1:w65").Select ' cancello il contenuto precedente
Selection.ClearContents
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.lottoanalyzer.it/analisi_estrazioni_uk_49s.asp", Destination:=Range( _
"$A$1"))
'.Name = "?page_id=108"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "4"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("K1:N23").Select ' tolgo dati importati che non mi servono
Selection.ClearContents
Range("R2").Select
Range("A2").Select
ActiveCell.FormulaR1C1 = "1" 'numero col A
Range("A3").Select
ActiveCell.FormulaR1C1 = "=R[-1]C+1"
Range("A3").Select
Selection.AutoFill Destination:=Range("A3:A22"), Type:=xlFillDefault
Range("A3:A22").Select
Range("A2:A22").Select
Selection.Font.Bold = True
Selection.Locked = True
Selection.FormulaHidden = True
Range("L2").Select
Range("O2").Select
Unload userform1
End Sub
Sub Aggiornaestrazionifglarchivio()
Set WS1 = Worksheets("appoggio") 'dove preleva
Set WS2 = Worksheets("Archivio_UK49s") ' dove deve inserire se mancante
Worksheets("Archivio_UK49s").Unprotect
UR1 = WS1.Range("C" & Rows.Count).End(xlUp).Row
UR2 = WS2.Range("B" & Rows.Count).End(xlUp).Row
DataA = DateSerial(Mid(WS2.Range("B" & UR2).Value, 7, 4), Mid(WS2.Range("B" & UR2).Value, 4, 1), Mid(WS2.Range("B" & UR2).Value, 1, 2))
DataApp = DateSerial(Mid(WS1.Range("C" & UR1).Value, 7, 4), Mid(WS1.Range("C" & UR1).Value, 4, 1), Mid(WS1.Range("C" & UR1).Value, 1, 2))
If DataA = DataApp Then
MsgBox "Non ci sono aggioramenti"
GoTo SaltaAgg
Else
For RR1 = UR1 To 3 Step -1
DataApp = DateSerial(Mid(WS1.Range("C" & RR1).Value, 7, 4), Mid(WS1.Range("C" & RR1).Value, 4, 1), Mid(WS1.Range("C" & RR1).Value, 1, 2))
If DataA = DataApp Then
RigaA = RR1 + 1
GoTo Aggiorna
End If
Next RR1
End If
Aggiorna:
For RR1 = RigaA To UR1
UR2 = WS2.Range("B" & Rows.Count).End(xlUp).Row + 1
WS2.Range("B" & UR2).Value = WS1.Range("A" & RR1).Value
WS2.Range("C" & UR2 & ":I" & UR2).Value = WS1.Range("D" & RR1 & ":J" & RR1).Value
Next RR1
MsgBox "Archivio Aggiornato"
SaltaAgg:
End Sub
DataA = WS2.Range("B" & UR2).Value
DataApp = WS1.Range("C" & UR1).Value
Range("O2").Select 'esistente
'aggiungere le prossime 3
If Cells(Rows.Count, "C").End(xlUp).Value <> Cells(Rows.Count, "C").End(xlUp).Offset(-1, 0).Value Then
Cells(Rows.Count, "C").End(xlUp).Offset(0, -1).Resize(1, 10).ClearContents
End If
Unload userform1 'esistente
WS2.Range("B" & UR2).Value = WS1.Range("C" & RR1).Value
per questo dovrebbe bastare questa aggiunta in coda alla macro AggUK49:
Range("O2").Select 'esistente
'aggiungere le prossime 3
If Cells(Rows.Count, "C").End(xlUp).Value <> Cells(Rows.Count, "C").End(xlUp).Offset(-1, 0).Value Then
Cells(Rows.Count, "C").End(xlUp).Offset(0, -1).Resize(1, 10).ClearContents
End If
Unload userform1 'esistente
Sub Aggiornaestrazionifglarchivio()
Set WS1 = Worksheets("appoggio") 'dove preleva
Set WS2 = Worksheets("Archivio_UK49s") ' dove deve inserire se mancante
Worksheets("Archivio_UK49s").Unprotect
UR1 = WS1.Range("C" & Rows.Count).End(xlUp).Row
UR2 = WS2.Range("B" & Rows.Count).End(xlUp).Row
DataA = DateSerial(Mid(WS2.Range("B" & UR2).Value, 7, 4), Mid(WS2.Range("B" & UR2).Value, 4, 1), Mid(WS2.Range("B" & UR2).Value, 1, 2))
DataApp = DateSerial(Mid(WS1.Range("C" & UR1).Value, 7, 4), Mid(WS1.Range("C" & UR1).Value, 4, 1), Mid(WS1.Range("C" & UR1).Value, 1, 2))
If DataA = DataApp Then
MsgBox "Non ci sono aggioramenti"
GoTo SaltaAgg
Else
For RR1 = UR1 To 3 Step -1
DataApp = DateSerial(Mid(WS1.Range("C" & RR1).Value, 7, 4), Mid(WS1.Range("C" & RR1).Value, 4, 1), Mid(WS1.Range("C" & RR1).Value, 1, 2))
If DataA = DataApp Then
RigaA = RR1 + 1
GoTo Aggiorna
End If
Next RR1
End If
Aggiorna:
For RR1 = RigaA To UR1
UR2 = WS2.Range("B" & Rows.Count).End(xlUp).Row + 1
WS2.Range("B" & UR2).Value = WS1.Range("C" & RR1).Value
WS2.Range("C" & UR2 & ":I" & UR2).Value = WS1.Range("D" & RR1 & ":J" & RR1).Value
Next RR1
MsgBox "Archivio Aggiornato"
SaltaAgg:
End Sub
Torna a Applicazioni Office Windows
Classi e radici quadrate applicate ai 90 numeri del lotto. Autore: nelson1331 |
Forum: Applicazioni Office Windows Risposte: 8 |
cercare e prelevare 128 estraz del lotto Autore: raimea |
Forum: Applicazioni Office Windows Risposte: 6 |
Questo progetto (dedicato al lotto), si puo' realizzare ? Autore: nelson1331 |
Forum: Applicazioni Office Windows Risposte: 18 |
Visitano il forum: Nessuno e 66 ospiti