Moderatori: Anthony47, Flash30005
Public Ws1, Ws2, Ws3 As Worksheet
Sub ImportaGiornate()
Application.ScreenUpdating = False
Sheets("ArchGiornate").Select
Cells.Clear
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.statisticbet.com/campionati/Portogallo/Liga-de-Honra_99/anno_109.html" _
, Destination:=Range("A1"))
.Name = "anno_110"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,9,12,15,18,21,24,27,30,33,36,39,42,45,48,51,54,57,60,63,66,69,72,75"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("B:B").Delete Shift:=xlToLeft
Columns("C:C").Delete Shift:=xlToLeft
Columns("D:D").Delete Shift:=xlToLeft
Call EliminaRigheVuote
Call ImportaClassifica
Worksheets("ClassAna").Select
Application.ScreenUpdating = True
End Sub
Sub ImportaClassifica()
Sheets("ClassGen").Select
Cells.Clear
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.statisticbet.com/mainframe.php", Destination:=Range("A1"))
.Name = "mainframe"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.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
End Sub
Sub EliminaRigheVuote()
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
UR3 = Ws3.Range("AD" & Rows.Count).End(xlUp).Row
Ws3.Range("AD2:AD" & UR3).ClearContents
Conta = 0
For RV = UR1 To 1 Step -1
If Ws1.Range("A" & RV).Value = "" Then
Conta = Conta + 1
Else
Conta = 0
End If
If Conta > 1 Then Rows(RV & ":" & RV).Delete Shift:=xlUp
Next RV
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
For RD = 1 To UR1 - 8 Step 10
StrD = Ws1.Range("A" & RD).Text
If Mid(StrD, 1, 9) = "Risultati" Then
DataS = DateSerial(Val(Mid(StrD, Len(StrD) - 3, 4)), Val(Mid(StrD, Len(StrD) - 6, 2)), Val(Mid(StrD, Len(StrD) - 9, 2)))
Ws1.Range("A" & RD).Value = DataS
UR3 = Ws3.Range("AD" & Rows.Count).End(xlUp).Row + 1
Ws3.Range("AD" & UR3).Value = DataS
End If
Next RD
Ws3.Select
UR3 = Ws3.Range("AD" & Rows.Count).End(xlUp).Row
Ws3.Range("Y1").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$AD$2:$AD$" & UR3
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub CreaClassifica()
'Set Ws1 = Sheets("ArchGiornate")
'Set Ws2 = Sheets("ClassGen")
'Set Ws3 = Worksheets("ClassAna")
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
DataC = Ws3.Range("Y1").Value
For RD = 1 To UR1 - 8 Step 10
If Ws1.Range("A" & RD).Value = DataC Then URD = RD - 2
Next RD
Ws3.Range("B2:U17").ClearContents
For SqC = 2 To 17
Sq = Ws3.Range("A" & SqC).Value
For RR1 = 2 To URD
For Col = 1 To 2
If Ws1.Cells(RR1, Col).Value = Sq Then
Ws3.Cells(SqC, 3).Value = Ws3.Cells(SqC, 3).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 10).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 10).Value + 1
RisC = Ws1.Range("C" & RR1).Value
If Col = 1 Then
RisVC = Val(Mid(RisC, 2, 1))
RisSqA = Val(Mid(RisC, 4, 1))
Else
RisSqA = Val(Mid(RisC, 2, 1))
RisVC = Val(Mid(RisC, 4, 1))
End If
If RisVC > RisSqA Then
Ws3.Range("D" & SqC).Value = Ws3.Range("D" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 11).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 11).Value + 1
End If
If RisVC < RisSqA Then
Ws3.Range("F" & SqC).Value = Ws3.Range("F" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 13).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 13).Value + 1
End If
If RisVC = RisSqA Then
Ws3.Range("E" & SqC).Value = Ws3.Range("E" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 12).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 12).Value + 1
End If
Ws3.Range("G" & SqC).Value = Ws3.Range("G" & SqC).Value + RisVC
Ws3.Range("H" & SqC).Value = Ws3.Range("H" & SqC).Value + RisSqA
Ws3.Range("I" & SqC).Value = Ws3.Range("G" & SqC).Value - Ws3.Range("H" & SqC).Value
Ws3.Cells(SqC, (Col - 1) * 6 + 14).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 14).Value + RisVC
Ws3.Cells(SqC, (Col - 1) * 6 + 15).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 15).Value + RisSqA
End If
Next Col
Next RR1
Ws3.Range("B" & SqC).Value = Ws3.Range("D" & SqC).Value * 3 + Ws3.Range("E" & SqC).Value * 2
Next SqC
Range("A1:U17").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("I2") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Columns("C:U").EntireColumn.AutoFit
Range("A1").Select
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$Y$1" Then Exit Sub
Call CreaClassifica
End Sub
Private Sub Workbook_Open()
Set Ws1 = Sheets("ArchGiornate")
Set Ws2 = Sheets("ClassGen")
Set Ws3 = Worksheets("ClassAna")
End Sub
Flash30005 ha scritto:Riguardo al tuo quesito dovrei farti una domanda
La classifica generale non riporta già tutti i dati che richiedi?
peppegiuseppe ha scritto:si effettivamente è cosi ma vorrei una cosa piu automatica... mi spiego meglio
per ogni giornata, a partire dalla 7a, analizzo la classifica della giornata precedente... così per tutte le giornate fino alla 24a. quindi se la giornata disputata è la 13a mi servono i valori (posizione in classifica, gol fatti e subiti, giornate disputate) di quella precedente, quindi della 12a.
facendo manualmente verrebbe una cosa molto lunga soprattutto se devo ripetere l'operazione per piu partite, piu giornate, piu stagioni e piu competizioni...
Sub CreaClassifica()
UR1 = Ws1.Range("A" & Rows.Count).End(xlUp).Row
DataC = Ws3.Range("Y1").Value
For RD = 1 To UR1 - 8 Step 10
If Ws1.Range("A" & RD).Value = DataC Then URD = RD - 2
Next RD
Ws3.Range("B2:U17").ClearContents
Ws3.Range("A2:A17").Interior.ColorIndex = xlNone
For SqC = 2 To 17
Sq = Ws3.Range("A" & SqC).Value
For RR1 = 51 To URD
If RR1 > URD - 8 Then
Mem = 1
Else
Mem = 0
End If
For Col = 1 To 2
If Ws1.Cells(RR1, Col).Value = Sq Then
Ws3.Cells(SqC, 3).Value = Ws3.Cells(SqC, 3).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 10).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 10).Value + 1
RisC = Ws1.Range("C" & RR1).Value
If Col = 1 Then
RisVC = Val(Mid(RisC, 2, 1))
RisSqA = Val(Mid(RisC, 4, 1))
Else
RisSqA = Val(Mid(RisC, 2, 1))
RisVC = Val(Mid(RisC, 4, 1))
End If
If RisVC > RisSqA Then
Ws3.Range("D" & SqC).Value = Ws3.Range("D" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 11).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 11).Value + 1
End If
If RisVC < RisSqA Then
Ws3.Range("F" & SqC).Value = Ws3.Range("F" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 13).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 13).Value + 1
End If
If RisVC = RisSqA Then
Ws3.Range("E" & SqC).Value = Ws3.Range("E" & SqC).Value + 1
Ws3.Cells(SqC, (Col - 1) * 6 + 12).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 12).Value + 1
If Mem = 1 Then Ws3.Range("A" & SqC).Interior.ColorIndex = 6
End If
Ws3.Range("G" & SqC).Value = Ws3.Range("G" & SqC).Value + RisVC
Ws3.Range("H" & SqC).Value = Ws3.Range("H" & SqC).Value + RisSqA
Ws3.Range("I" & SqC).Value = Ws3.Range("G" & SqC).Value - Ws3.Range("H" & SqC).Value
Ws3.Cells(SqC, (Col - 1) * 6 + 14).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 14).Value + RisVC
Ws3.Cells(SqC, (Col - 1) * 6 + 15).Value = Ws3.Cells(SqC, (Col - 1) * 6 + 15).Value + RisSqA
End If
Next Col
Next RR1
Ws3.Range("B" & SqC).Value = Ws3.Range("D" & SqC).Value * 3 + Ws3.Range("E" & SqC).Value * 2
Next SqC
Range("A1:U17").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("I2") _
, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Columns("C:U").EntireColumn.AutoFit
Range("A1").Select
End Sub
xlBetween, Formula1:="=$AD$8:$AD$" & UR3
Flash30005 ha scritto:P.s. Mi hai inviato l'esempio per la giornata 7 quindi con classifica alla 6ª ma come mai ci sono tutte quelle partite giocate se dobbiamo considerare dalla sesta in poi? Dovremmo avere solo una partita giocata, o ho interpretato male qualcosa?
Flash30005 ha scritto:Cosa significa non avevi salvato il file?
Per fare il test devi averlo scaricato e salvato su disco
eventualmente l'hai cancellato!
Forse perché non lo ritenevi interessante?
Beh, conserva questo perché non lo invierò un'altra volta
http://www.megaupload.com/?d=VFZQLMSI
Ciao
peppegiuseppe ha scritto:non capisco nella classifica si vede chiaramente nella colonna H che le giornate sono 6
in pratica a me interessano le giornate dalla 7 alla 24, che poi ci siano altre partite (1a-6a/ 25a-30a) non importa...
For RR1 = 51 To URD
For RR1 = 2 To URD
peppegiuseppe ha scritto:squadra pt giocate
Feirense 21 12
Trofense 20 12
Oliveirense 20 12
Leixoes 17 12
Arouca 17 12
Gil Vicente 17 12
Estoril 16 12
Varzim 16 12
Santa Clara 16 12
Penafiel 16 12
Moreirense 15 12
Covilha 14 12
Aves 13 12
Freamunde 13 12
Belenenses 13 12
Fatima 9 12
Torna a Applicazioni Office Windows
Macro per aprire file salvato su sharepoint Onedrive Autore: marcopont |
Forum: Applicazioni Office Windows Risposte: 2 |
Come impostare il formato data predefinito in excel? Autore: wallace&gromit |
Forum: Applicazioni Office Windows Risposte: 5 |
Come interrompere macro sndPlaySound Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
Visitano il forum: Nessuno e 15 ospiti