Ciao Flash30005,
come detto prima per me va bene già così,
per evidenziare correttamente l'ultima del mese ho messo una condizione in fondo alla macro che mi elimina una cella vuota in su ,così va tutto ok.
ti ringrazio tantissimo.
Moderatori: Anthony47, Flash30005
Sub TrovaEstr()
UR = Worksheets("Archivio").Range("A" & Rows.Count).End(xlUp).Row
Range("B3:B10000").ClearContents
MM = ""
CS = 0
For RR = 3 To UR
If Len(Range("C" & RR).Value) > 9 Then
If Month(Range("C" & RR).Value) <> MM Then
If Range("J2").Value <> 4 Then
For RS = 1 To 4
If Range("J2").Value = RS Then
CS = CS + 1
Range("B" & RR).Value = CS
RR = RR - 1
End If
RR = RR + 1
Next RS
MM = Month(Range("C" & RR).Value)
Else
If MM <> "" Then
CS = CS + 1
Range("B" & RigaP).Value = CS
End If
End If
Else
RigaP = RR
End If
MM = Month(Range("C" & RR).Value)
End If
Next RR
End Sub
Application.EnableEvents = False
Application.EnableEvents = True
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$J$2" Then Exit Sub
TrovaEstr
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$J$2" Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
TrovaEstr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Flash30005 ha scritto:Pertanto puoi inserire le classiche righe codice qui
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$J$2" Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
TrovaEstr
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim bCalc As XlCalculation
If Target.Address <> "$J$2" Then Exit Sub
With Application
bCalc = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
TrovaEstr
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = bCalc
End With
End Sub
Sub TrovaEstr()
UR = Worksheets("Archivio").Range("A" & Rows.Count).End(xlUp).Row
Range("B3:B10000").ClearContents
MM = Month(Range("C3").Value) '<<<<<<<<<<<<< inizio archivio
CS = 0
ES = Range("J2").Value
For RR = 3 To UR
If Len(Range("C" & RR).Value) > 9 Then
If Month(Range("C" & RR).Value) <> MM Then
For RS = 1 To ES
If ES = RS Then
CS = CS + 1
Range("B" & RR).Value = CS
RR = RR - 1
End If
RR = RR + 1
Next RS
MM = Month(Range("C" & RR).Value)
Else
RigaP = RR
End If
MM = Month(Range("C" & RR).Value)
End If
Next RR
End Sub
1;2;3;4;5;6;7;8;9;FM
Sub TrovaEstr()
UR = Worksheets("Archivio").Range("A" & Rows.Count).End(xlUp).Row
If UR < 3 Then UR = 3
Range("B3:B" & UR).ClearContents
MM = Month(Range("C3").Value)
CS = 0
Application.EnableEvents = False
ES = Range("J2").Value
For RR = 3 To UR
If Len(Range("C" & RR).Value) > 9 Then
If Month(Range("C" & RR).Value) <> MM Then
If ES <> "FM" Then
For RS = 1 To ES
If ES = RS Then
CS = CS + 1
If Range("C" & RR).Value <> "" Then Range("B" & RR).Value = CS
RR = RR - 1
End If
RR = RR + 1
Next RS
MM = Month(Range("C" & RR).Value)
Else
CS = CS + 1
If MM <> "" Then Range("B" & RigaP).Value = CS
End If
Else
RigaP = RR
End If
MM = Month(Range("C" & RR).Value)
End If
Next RR
Application.EnableEvents = True
End Sub
Torna a Applicazioni Office Windows
Automatizzare numero settimane nel mese di un anno Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 3 |
Collegamento che punta a una qualunque fine colonna Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 7 |
Come nascondere I Numeri non Appartenenti Al Mese Deside Autore: Maury170419 |
Forum: Applicazioni Office Windows Risposte: 3 |
Date CUP Web prenotabili su foglio excel Autore: aggittoriu |
Forum: Applicazioni Office Windows Risposte: 17 |
Visitano il forum: Nessuno e 97 ospiti