Moderatori: Anthony47, Flash30005
Sub SumGol()
Dim WArr(), wInd As Long, tArr(1 To 4)
Dim GeS As Worksheet, LastN As Long, myMatch
Dim I As Long, J As Long, cSum
'
Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row
ReDim WArr(1 To LastN, 1 To 4)
For I = 8 To LastN
cSum = GeS.Cells(I, "N")
myMatch = Application.Match(cSum, GeS.Range("N8").Resize(I - 7, 1), False)
If IsError(myMatch) Then
wInd = wInd + 1
WArr(wInd, 1) = cSum
WArr(wInd, 2) = 1
If UCase(GeS.Cells(I, "K").Value) = "V" Then
WArr(wInd, 3) = 1 'V
Else
WArr(wInd, 4) = 1 'P
End If
Else
If myMatch > wInd Then wInd = myMatch
WArr(myMatch, 1) = cSum
WArr(myMatch, 2) = WArr(myMatch, 2) + 1
If UCase(GeS.Cells(I, "K").Value) = "V" Then
WArr(myMatch, 3) = WArr(myMatch, 3) + 1 'V
Else
WArr(myMatch, 4) = WArr(myMatch, 4) + 1 'P
End If
End If
Next I
'Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
'Bubble sort:
For I = 1 To wInd - 1
For J = I + 1 To wInd
If WArr(I, 1) > WArr(J, 1) Then
tArr(4) = WArr(I, 4)
tArr(3) = WArr(I, 3)
tArr(2) = WArr(I, 2)
tArr(1) = WArr(I, 1)
'
WArr(I, 4) = WArr(J, 4)
WArr(I, 3) = WArr(J, 3)
WArr(I, 2) = WArr(J, 2)
WArr(I, 1) = WArr(J, 1)
'
WArr(J, 4) = tArr(4)
WArr(J, 3) = tArr(3)
WArr(J, 2) = tArr(2)
WArr(J, 1) = tArr(1)
End If
Next J
Next I
Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
End Sub
Sub SumGol2()
Dim WArr(), wInd As Long, tArr(1 To 4), mArr
Dim GeS As Worksheet, LastN As Long, myMatch
Dim I As Long, J As Long, cSum
'
Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row
ReDim WArr(1 To LastN, 1 To 4)
ReDim mArr(1 To LastN)
For I = 8 To LastN
mArr = Application.WorksheetFunction.Index(WArr, 0, 1)
cSum = GeS.Cells(I, "N")
myMatch = Application.Match(cSum, mArr, False)
If IsError(myMatch) Then
wInd = wInd + 1
WArr(wInd, 1) = cSum
WArr(wInd, 2) = 1
If UCase(GeS.Cells(I, "K").Value) = "V" Then
WArr(wInd, 3) = 1 'V
Else
WArr(wInd, 4) = 1 'P
End If
Else
WArr(myMatch, 1) = cSum
WArr(myMatch, 2) = WArr(myMatch, 2) + 1
If UCase(GeS.Cells(I, "K").Value) = "V" Then
WArr(myMatch, 3) = WArr(myMatch, 3) + 1 'V
Else
WArr(myMatch, 4) = WArr(myMatch, 4) + 1 'P
End If
End If
'Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
Next I
'Bubble sort:
For I = 1 To wInd - 1
For J = I + 1 To wInd
If WArr(I, 1) > WArr(J, 1) Then
tArr(4) = WArr(I, 4)
tArr(3) = WArr(I, 3)
tArr(2) = WArr(I, 2)
tArr(1) = WArr(I, 1)
'
WArr(I, 4) = WArr(J, 4)
WArr(I, 3) = WArr(J, 3)
WArr(I, 2) = WArr(J, 2)
WArr(I, 1) = WArr(J, 1)
'
WArr(J, 4) = tArr(4)
WArr(J, 3) = tArr(3)
WArr(J, 2) = tArr(2)
WArr(J, 1) = tArr(1)
End If
Next J
Next I
Sheets("Squadre").Range("AC7").Resize(wInd, 4).Value = WArr
End Sub
ma io non sono in grado di modificare / sistemare la macro
Sub SumGol()
Dim WArr(), wInd As Long, tArr(1 To 4), mArr
Dim GeS As Worksheet, LastN As Long, myMatch
Dim i As Long, j As Long, cSum
'-------------------------
' gennaio 23
' preleva e ordina la colonna masaniello fgl Tabelle
' da pc-facile antony47
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=112756&p=662823#p662823
'--------------------------------
Sheets("Tabelle").Select
Application.ScreenUpdating = False 'blocca sfarfallio e non vedo cambiare fgl
INIZIO = Timer
UserForm1.Show vbModeless
DoEvents
Worksheets("Tabelle").Unprotect ' togli protez
Set GeS = Sheets("Generale")
LastN = GeS.Cells(Rows.Count, "N").End(xlUp).Row
Range("x7:AA1000").ClearContents ' cnacella elimina dati precedenti
ReDim WArr(1 To LastN, 1 To 4)
ReDim mArr(1 To LastN)
For i = 8 To LastN
mArr = Application.WorksheetFunction.Index(WArr, 0, 1)
cSum = GeS.Cells(i, "N")
myMatch = Application.Match(cSum, mArr, False)
If IsError(myMatch) Then
wInd = wInd + 1
WArr(wInd, 1) = cSum
WArr(wInd, 2) = 1
If UCase(GeS.Cells(i, "K").Value) = "Vinta" Then
WArr(wInd, 3) = 1 'V
Else
WArr(wInd, 4) = 1 'P
End If
Else
WArr(myMatch, 1) = cSum
WArr(myMatch, 2) = WArr(myMatch, 2) + 1
If UCase(GeS.Cells(i, "K").Value) = "Vinta" Then
WArr(myMatch, 3) = WArr(myMatch, 3) + 1 'V
Else
WArr(myMatch, 4) = WArr(myMatch, 4) + 1 'P
End If
End If
'Sheets("Tabelle").Range("AC7").Resize(wInd, 4).Value = WArr
Next i
'Bubble sort:
For i = 1 To wInd - 1
For j = i + 1 To wInd
If WArr(i, 1) > WArr(j, 1) Then
tArr(4) = WArr(i, 4)
tArr(3) = WArr(i, 3)
tArr(2) = WArr(i, 2)
tArr(1) = WArr(i, 1)
'
WArr(i, 4) = WArr(j, 4)
WArr(i, 3) = WArr(j, 3)
WArr(i, 2) = WArr(j, 2)
WArr(i, 1) = WArr(j, 1)
'
WArr(j, 4) = tArr(4)
WArr(j, 3) = tArr(3)
WArr(j, 2) = tArr(2)
WArr(j, 1) = tArr(1)
End If
Next j
Next i
Sheets("Tabelle").Range("X7").Resize(wInd, 4).Value = WArr ' dove mettere i dati
'-----------------------
'-------coloro riga si no --------------------------------
For Z = 7 To Cells(Rows.Count, "X").End(xlUp).Row ' 7 1ma riga
Range("X7:AA1000").Interior.ColorIndex = 2 '<<< sfondo bianco
Range("X7:AA1000").Font.Bold = False
Next Z
For RR = 7 To Z Step 2
Range("X" & RR & ":AA" & RR).Interior.ColorIndex = 36
Range("X" & RR & ":AA" & RR).Font.Bold = True
Next RR
'---------
Application.ScreenUpdating = True ' riattiva sfarfallio
Unload UserForm1
fine = Timer
MsgBox ("Tempo impiegato " & Int((fine - INIZIO) / 60) & " min " & (fine - INIZIO) Mod 60 & " Sec")
' -- blocca proteggi foglio----------------------------
' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFormattingRows:=True
End Sub
If UCase(GeS.Cells(i, "K").Value) = "VINTA" Then 'NON "Vinta"
Torna a Applicazioni Office Windows
Aggiornare cella con somma quando aggiungo nuova colonna Autore: marcopont |
Forum: Applicazioni Office Windows Risposte: 1 |
Visitano il forum: Nessuno e 32 ospiti