Moderatori: Anthony47, Flash30005
Sub ContaUnici()
Risp = MsgBox(Prompt:="Attenzione stai per cancellare i dati già elaborati - Continuo?", Buttons:=vbYesNo)
If Risp = 6 Then
Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual
For FF = 1 To Worksheets.Count
If Len(Sheets(FF).Name) > 2 Then GoTo SaltaFF
Sheets(FF).Select
UR1 = Range("A" & Rows.Count).End(xlUp).Row
Range("CV3:GK" & UR1).ClearContents
Range("J3:CU" & UR1).ClearContents
For RR1 = 3 To UR1 - 18 Step 18
For NR = 1 To 90
MyPre = Evaluate("=SUM(COUNTIF(C" & RR1 & ":G" & RR1 + 17 & "," & NR & "))")
If MyPre = 1 Then
UC1 = Cells(RR1 + 17, Columns.Count).End(xlToLeft).Column + 1
If UC1 < 104 Then UC1 = 104
Cells(RR1 + 17, UC1).Value = NR
End If
Next NR
Next RR1
UR2 = Range("CZ" & Rows.Count).End(xlUp).Row
For Passo = 1 To 5
For RR2 = 20 To UR2 Step 18
UC2 = Cells(RR2, Columns.Count).End(xlToLeft).Column
For CC2 = 104 To UC2
NR = Cells(RR2, CC2).Value
If Passo = 1 Then
MyPre = Evaluate("=SUM(COUNTIF(C" & (RR2 + 1) + (Passo - 1) * 18 & ":G" & (RR2 + 18) + (Passo - 1) * 18 & "," & NR & "))")
Cells(RR2 - 1 - (Passo - 1), CC2).Value = MyPre
If MyPre > 0 Then
For RR3 = RR2 + 1 To RR2 + 18
MyPre3 = Evaluate("=SUM(COUNTIF(C" & RR3 & ":G" & RR3 & "," & NR & "))")
If MyPre3 = 1 Then Cells(RR3, NR + 9).Value = NR
Next RR3
End If
Range("CX" & RR2 - 1 - (Passo - 1)).Value = Passo * 18
Else
myform = "=MAX(R" & RR2 - 1 & "C" & CC2 & ":R" & RR2 - Passo + 1 & "C" & CC2 & ")"
If Application.ReferenceStyle = xlA1 Then myform = Application.ConvertFormula(myform, xlR1C1, xlA1)
MyMax = Evaluate(myform)
If MyMax = 0 Then
MyPre = Evaluate("=SUM(COUNTIF(C" & (RR2 + 1) + (Passo - 1) * 18 & ":G" & (RR2 + 18) + (Passo - 1) * 18 & "," & NR & "))")
Cells(RR2 - 1 - (Passo - 1), CC2).Value = MyPre
Range("CX" & RR2 - 1 - (Passo - 1)).Value = Passo * 18
End If
End If
Next CC2
Range("CW" & RR2 - 1 - (Passo - 1)).Value = Evaluate("=SUM(COUNTIF(CZ" & RR2 - 1 - (Passo - 1) & ":IV" & RR2 - 1 - (Passo - 1) & "," & 0 & "))")
Range("CW" & RR2).Value = Evaluate("=SUM(CW" & RR2 - 10 & ":CW" & RR2 - 1 & ")")
Range("CV" & RR2).Value = "Tot"
Next RR2
Next Passo
SaltaFF:
Next FF
ContaRitardi
Sheets("BA").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Fine = Timer - Start
MsgBox "Elaborato in " & Int(Fine) & " sec"
End If
End Sub
Sub ContaUniciAgg()
Start = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual
For FF = 1 To Worksheets.Count
If Len(Sheets(FF).Name) > 2 Then GoTo SaltaFF
Sheets(FF).Select
UR1 = Range("A" & Rows.Count).End(xlUp).Row
UR2 = Range("CZ" & Rows.Count).End(xlUp).Row
For RR1 = UR2 To UR1 - 18 Step 18
For NR = 1 To 90
MyPre = Evaluate("=SUM(COUNTIF(C" & RR1 & ":G" & RR1 + 17 & "," & NR & "))")
If MyPre = 1 Then
UC1 = Cells(RR1 + 17, Columns.Count).End(xlToLeft).Column + 1
If UC1 < 104 Then UC1 = 104
Cells(RR1 + 17, UC1).Value = NR
End If
Next NR
Next RR1
UR2 = Range("CZ" & Rows.Count).End(xlUp).Row
For Passo = 1 To 5
For RR2 = UR2 - 18 * 5 To UR1 Step 18
UC2 = Cells(RR2, Columns.Count).End(xlToLeft).Column
For CC2 = 104 To UC2
NR = Cells(RR2, CC2).Value
If Passo = 1 Then
MyPre = Evaluate("=SUM(COUNTIF(C" & RR2 + 1 & ":G" & RR2 + 18 & "," & NR & "))")
Cells(RR2 - 1, CC2).Value = MyPre
If MyPre > 0 Then
For RR3 = RR2 + 1 To RR2 + 18
MyPre3 = Evaluate("=SUM(COUNTIF(C" & RR3 & ":G" & RR3 & "," & NR & "))")
If MyPre3 = 1 Then Cells(RR3, NR + 9).Value = NR
Range("CX" & RR2 - 1 - (Passo - 1)).Value = Passo * 18
Next RR3
End If
Else
myform = "=MAX(R" & RR2 - 1 & "C" & CC2 & ":R" & RR2 - Passo + 1 & "C" & CC2 & ")"
If Application.ReferenceStyle = xlA1 Then myform = Application.ConvertFormula(myform, xlR1C1, xlA1)
MyMax = Evaluate(myform)
If MyMax = 0 Then
MyPre3 = Evaluate("=SUM(COUNTIF(C" & (RR2 + 1) + (Passo - 1) * 18 & ":G" & (RR2 + 18) + (Passo - 1) * 18 & "," & NR & "))")
Cells(RR2 - 1 - (Passo - 1), CC2).Value = MyPre3
Range("CX" & RR2 - 1 - (Passo - 1)).Value = Passo * 18
End If
End If
Next CC2
Range("CW" & RR2 - 1 - (Passo - 1)).Value = Evaluate("=SUM(COUNTIF(CZ" & RR2 - 1 - (Passo - 1) & ":IV" & RR2 - 1 - (Passo - 1) & "," & 0 & "))")
Range("CW" & RR2).Value = Evaluate("=SUM(CW" & RR2 - 10 & ":CW" & RR2 - 1 & ")")
Range("CV" & RR2).Value = "Tot"
Next RR2
Next Passo
SaltaFF:
Next FF
ContaRitardi
Sheets("BA").Select
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Fine = Timer - Start
MsgBox "Elaborato in " & Int(Fine) & " sec"
End Sub
In J3:
- Codice: Seleziona tutto
=SE(CONTA.SE($C3:$G19;J$1)=1;J$1;"")
Copia poi verso destra e poi in J22:BG22 e J41:BG41
Function inutile(ByRef myR As Range) As String
For I = 1 To 90
If Application.WorksheetFunction.CountIf(myR, I) = 1 Then myInut = myInut & "." & I
Next I
inutile = Mid(myInut, 2, 9999)
End Function
=inutile(C3:G19)
Sub Inut()
Range("J3") = Inutile(Range("C3:G19"))
Range("J22") = Inutile(Range("C22:G38"))
Range("J42") = Inutile(Range("C41:G57"))
End Sub
Torna a Applicazioni Office Windows
Macro che scatta quando cambia dato in un altro file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 7 |
Modidica Formula Somma I Riferimenti Autore: Francesco6918 |
Forum: Applicazioni Office Windows Risposte: 2 |
Excel: formula automatica per evidenziare prodotto scaduto Autore: gamma_ray |
Forum: Applicazioni Office Windows Risposte: 3 |
Problema con macro copia e rinomina file Autore: systemcrack |
Forum: Applicazioni Office Windows Risposte: 2 |
formula excel non visualizza risultato Autore: tommasog |
Forum: Applicazioni Office Windows Risposte: 6 |
Visitano il forum: Nessuno e 70 ospiti