Salve.
La routine presente nell'evento change è questa:
- Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = Cells.CountLarge Then Exit Sub
If Target.Column = 6 And Target.Count = 1 Then
Application.EnableEvents = False
If UCase(Target.Value) = "I" Then
If Target.Offset(0, -1) <> "" Then
If Left(Target.Offset(0, -1), 5) = "INTERNO: " Then
Else
Target.Offset(0, -1) = "INTERNO: " & Replace(Target.Offset(0, -1), "ESTERNO: ", "", , , vbTextCompare)
End If
Else
MsgBox "Nessun inserimento.", vbCritical + vbOKOnly, "Errore"
End If
ElseIf UCase(Target.Value) = "E" Then
If Target.Offset(0, -1) <> "" Then
If Left(Target.Offset(0, -1), 6) = "ESTERNO" Then
Else
Target.Offset(0, -1) = "ESTERNO: " & Replace(Target.Offset(0, -1), "INTERNO: ", "", , , vbTextCompare)
End If
Else
MsgBox "Nessun inserimento", vbCritical + vbOKOnly, "Errore"
End If
ElseIf Len(Trim(Target.Value)) = 0 Then
If Len(Trim(Target.Offset(0, -1))) <> 0 Then
If MsgBox("Non avvalorando il campo, verrà cancellata quello già inserito. Continuare ?", vbQuestion + vbYesNo, "Attenzione") = vbYes Then
Target.Offset(0, -1) = ""
End If
End If
ElseIf UCase(Target.Value) <> "E" And UCase(Target.Value) <> "I" Then
MsgBox "La scelta è errata. Inserire 'I' o 'E'. ", vbCritical + vbOKOnly, "Errore"
Target.Select
End If
Application.EnableEvents = True
End If
End Sub
che mi è stata fornita proprio su questo forum.
Secondo me il problema non è qui.
Purtroppo non posso postare il programma ( o parte di esso ) essendo infarcito di dati non pubblicabili ( e farne uno stralcio sarebbe impossibile, vista la complessità....).
Il problema è che, se svuoto il foglio con questo codice:
- Codice: Seleziona tutto
Dim f As String
f = ""
If fog = "F" Then f = "Foglio_lavoro"
If f <> "" Then
Sheets(f).Select
Cells.Select
Selection.ClearContents
Selection.Validation.Delete
Selection.Font.Bold = False
Selection.Font.Size = 10
Selection.Font.ColorIndex = nero
Selection.Interior.ColorIndex = nero
Selection.Font.Italic = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
'.MergeCells = True
End With
Selection.UnMerge
Selection.WrapText = False
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
e poi lo riscrivo con istruzioni del tipo:
- Codice: Seleziona tutto
form = ""
form = "=SE.ERRORE((ARROTONDA(SOMMA(G" & Trim(Str(interv_iniz)) & ":G" & Trim(Str(interv_fine)) & ")/(I" & Trim(Str(r_progress)) & "-H" & Trim(Str(r_progress)) & ");0));0)"
Sheets("Foglio_lavoro").Cells(r_progress, 7).FormulaLocal = form
Sheets("Foglio_lavoro").Cells(r_progress, 7).NumberFormat = "General"
Sheets("Foglio_lavoro").Cells(r_progress, 7).Font.Size = 9
Sheets("Foglio_lavoro").Cells(r_progress, 7).Font.ColorIndex = grigio25
Sheets("Foglio_lavoro").Cells(r_progress, 7).Validation.Delete
- Codice: Seleziona tutto
r_progress = r_progress + 1
Sheets("Foglio_lavoro").Cells(r_progress, 3).UnMerge
Sheets("Foglio_lavoro").Cells(r_progress, 3).ClearContents
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.ColorIndex = xlAutomatic
Sheets("Foglio_lavoro").Cells(r_progress, 3).HorizontalAlignment = xlRight
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Size = 9
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Bold = True
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Italic = False
Sheets("Foglio_lavoro").Cells(r_progress, 3).WrapText = True
Sheets("Foglio_lavoro").Cells(r_progress, 3).Value = "Giudizio " + Trim(Str(x))
- Codice: Seleziona tutto
Sheets("Foglio_lavoro").Cells(r_progress, 2).UnMerge
Sheets("Foglio_lavoro").Cells(r_progress, 2).ClearContents
Sheets("Foglio_lavoro").Cells(r_progress, 2).Value = Sheets("Base_dati").Cells(z, 7).Value
Sheets("Foglio_lavoro").Cells(r_progress, 2).Font.ColorIndex = xlAutomatic
Sheets("Foglio_lavoro").Cells(r_progress, 2).HorizontalAlignment = xlLeft
Sheets("Foglio_lavoro").Cells(r_progress, 2).Font.Size = 9
Sheets("Foglio_lavoro").Cells(r_progress, 2).Font.Bold = False
Sheets("Foglio_lavoro").Cells(r_progress, 2).Font.Italic = False
Call bordo("Foglio_lavoro", "T", "B" & Trim(Str(r_progress)), "B" & Trim(Str(r_progress)), 1, 1, 1, 1)
' verifica descrizione
Sheets("Foglio_lavoro").Cells(r_progress, 3).UnMerge
Sheets("Foglio_lavoro").Cells(r_progress, 3).ClearContents
Sheets("Foglio_lavoro").Cells(r_progress, 3).Value = Sheets("Base_dati").Cells(z, 9).Value
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.ColorIndex = xlAutomatic
Sheets("Foglio_lavoro").Cells(r_progress, 3).HorizontalAlignment = xlLeft
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Size = 9
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Bold = False
Sheets("Foglio_lavoro").Cells(r_progress, 3).Font.Italic = False
Sheets("Foglio_lavoro").Cells(r_progress, 3).WrapText = True
Call bordo("Foglio_lavoro", "T", "C" & Trim(Str(r_progress)), "C" & Trim(Str(r_progress)), 1, 1, 1, 1)
già al secondo riempimento la routine diventa sempre più lenta ...... Excel comincia a "non rispondere" per periodi sempre superiori fino, di fatti, a bloccarsi ......
Comunque, ho applicato la soluzione proposta da Anthony che soddisfa le mie esigenze anche se il non dover nascondere, scoprire, duplicare, cancellare i fogli di appoggio non è proprio il massimo ..... ma funziona !!!
Grazie