Moderatori: Anthony47, Flash30005
Utilizzare una sola riga di "18" celle (Tabella "A") NON dovrai inserire righe
Utilizzare una sola riga di "5" celle (Tabella "A") NON dovrai inserire righe
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2:F2")) Is Nothing Then
If Target.Count > 1 Then
MsgBox "Operare su una sola cella", vbExclamation
Exit Sub
Else
If Target.Column = 6 And Target <> "" Then
Dim UR As Integer, I As Integer, J As Integer, K As Integer, Trovati As Integer
Application.EnableEvents = False
UR = Range("A" & Rows.Count).End(xlUp).Row
If Cells(21, "B") = "" Then
' ..........................................................................................................................................
' CAMBIA il testo che viene scritto nelle 5 celle o elimina la seguente istruzione
Range("B1") = "Primo": Range("C1") = "Secondo": Range("D1") = "Terzo": Range("E1") = "Quarto": Range("F1") = "Quinto"
' ..........................................................................................................................................
Range("B1:F1").Copy Destination:=Range("B21")
End If
If UR > 21 Then
Range("B22:F22").Insert Shift:=xlDown
Range("B2:F2").Copy Destination:=Range("B22")
UR = UR + 1
Trovati = 0
For I = 2 To 6
For J = 23 To UR
For K = 2 To 6
If Cells(J, I) <> "" And Cells(J, I) = Cells(22, K) Then
Cells(J, I) = ""
Trovati = Trovati + 1
End If
Next K
Next J
Next I
Else
Range("B2:F2").Copy Destination:=Range("B22")
End If
'......................................................................
' Alla fine delle tue prove elimina le due istruzioni che seguono
Range("H22:L22").Insert Shift:=xlDown
Range("B2:F2").Copy Destination:=Range("H22")
'......................................................................
Range("B2:F2").ClearContents
UR = Range("A" & Rows.Count).End(xlUp).Row + 1
If UR < 22 Then
UR = 22
End If
Cells(UR, "A") = Cells(UR - 1, "A") + 1
Application.EnableEvents = True
If Trovati > 0 Then
MsgBox "Sono stati trovati: " & Trovati & " numeri uguali", vbInformation
End If
End If
End If
End If
End Sub
=E(B22<>""; B22=$H$2)
Range("B23:F23").Copy
Range("B22:F22").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("B2:F2").Copy Destination:=Range("B22")
UR = UR + 1
Range("B2:F2").Copy Destination:=Range("B22")
Range("B23:F23").Copy ' <<=== INSERITA
Range("B22:F22").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False ' <<=== INSERITA
UR = UR + 1
=E(B22<>""; B22=$H$2)
="Range(""B2:F2"")=E(B22<>""; B22=$H$2):=Range(""B22"")Range(""B23:F23"").Copy '=E(B22<>""; B22=$H$2)Range(""B22:F22"").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=False '=E(B22<>""""; B22=$H$2)UR = UR + 1"
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2:F2")) Is Nothing Then
If Target.Count > 1 Then
MsgBox "Operare su una sola cella", vbExclamation
Exit Sub
Else
If Target.Column = 6 And Target <> "" Then
Dim UR As Integer, I As Integer, J As Integer, K As Integer, Trovati As Integer
Application.EnableEvents = False
UR = Range("A" & Rows.Count).End(xlUp).Row
If Cells(21, "B") = "" Then
' ..........................................................................................................................................
' CAMBIA il testo che viene scritto nelle 5 celle o elimina la seguente istruzione
Range("B1") = "Primo": Range("C1") = "Secondo": Range("D1") = "Terzo": Range("E1") = "Quarto": Range("F1") = "Quinto"
' ..........................................................................................................................................
Range("B1:F1").Copy Destination:=Range("B21")
End If
If UR > 21 Then
Range("B22:F22").Insert Shift:=xlDown
Range("B2:F2").Copy Destination:=Range("B22")
' QUI .....................................................................................................
Range("B23:F23").Copy ' <<=== INSERITA
Range("B22:F22").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False ' <<=== INSERITA
' QUI .....................................................................................................
UR = UR + 1
Trovati = 0
For I = 2 To 6
For J = 23 To UR
For K = 2 To 6
If Cells(J, I) <> "" And Cells(J, I) = Cells(22, K) Then
Cells(J, I) = ""
Trovati = Trovati + 1
End If
Next K
Next J
Next I
Else
Range("B2:F2").Copy Destination:=Range("B22")
End If
'......................................................................
' Alla fine delle tue prove elimina le due istruzioni che seguono
Range("H22:L22").Insert Shift:=xlDown
Range("B2:F2").Copy Destination:=Range("H22")
'......................................................................
Range("B2:F2").ClearContents
UR = Range("A" & Rows.Count).End(xlUp).Row + 1
If UR < 22 Then
UR = 22
End If
Cells(UR, "A") = Cells(UR - 1, "A") + 1
Application.EnableEvents = True
If Trovati > 0 Then
MsgBox "Sono stati trovati: " & Trovati & " numeri uguali", vbInformation
End If
End If
End If
End If
End Sub
Torna a Applicazioni Office Windows
cancella righe completamente vuote Autore: trittico69 |
Forum: Applicazioni Office Windows Risposte: 3 |
Barra Applicazioni tasto destro non attivo e ALTRO Autore: ricky53 |
Forum: Sistemi Operativi Windows Risposte: 6 |
Scelta da elenco a discesa che ne apre un altro Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 12 |
Visitano il forum: Nessuno e 21 ospiti