SCRIVERE IN AUTOMATICO IN CARATTERE MAIUSCOLO

Question

Buongiorno, ho trovato questa macro:

=========================================

Sub Uppercase()

   ' Loop to cycle through each cell in the specified range.

   For Each x In Range("A5")

      ' Change the text in the range to uppercase letters.

      x.Value = UCase(x.Value)

   Next

End Sub

===========================================

Purtroppo non mi si attiva in automatico. Come posso fare?

Grazie

Fabio

Answer 1

Salve ho incollato quest'ultimo codice e all'apertura mi compare questo messaggio:

"errore run time 1004 errore definito dall'applicazione o dall'oggetto"

Grazie

Fabio

Per favore non si arrabbi con me :)

trovata la riga evidenziata:

 blCondition = CBool(InStr(10, .Formula1, aDate, vbBinaryCompare))

Ciao Fabio,

Da me il codice funziona senza alcun problema e questo e' lo stesso codice che hai utilizzato da qualque tempo. 

In ogni modo, nel modulo del codice del foglio LIQUIDI, sostituisci tutto il codice con la seguente versione:

'==========>>

Option Explicit

Const sIndirizzo As String = "I37:I51, D52:D55"

Const myFlag As String = "X"

'---------->>

Private Sub Worksheet_Activate()

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sStr As String

    Dim aDate As String

    Dim iPos As Long

    Dim Res As Variant

    Dim blCondition As Boolean

    aDate = Format(Date, "dd/mm/yy")

On Error GoTo XIT:

    Set Rng = Me.Range(sIndirizzo)

    For Each rCell In Rng.Cells

        With rCell

            If UCase(.Value) = UCase(myFlag) Then

                With .Offset(0, 1).FormatConditions.Item(1)

                    blCondition = CBool(InStr(10, .Formula1, aDate, vbBinaryCompare))

                    If blCondition Then

                        If Not Rng2 Is Nothing Then

                            Set Rng2 = Union(Rng2, rCell)

                        Else

                            Set Rng2 = rCell

                        End If

                    End If

                End With

            End If

        End With

    Next rCell

    If blCondition Then

        Res = MsgBox(Prompt:="Attenzione vi sono parametri evidenziati." _

                             & vbNewLine _

                             & "sulle celle:" _

                             & vbNewLine & Rng2.Address(0, 0) & vbNewLine _

                             & "Vuoi deselezionarli?", _

                     Buttons:=vbYesNo, _

                     Title:="ATTENZIONE!")

        If Res = vbYes Then

            Application.EnableEvents = False

            With Rng2

                .ClearContents

                .Offset(0, 1).FormatConditions.Delete

            End With

            Application.EnableEvents = True

        End If

    End If

XIT:

Call MsgBox(Prompt:="Error " & Err.Number & " (" & Err.Description & ")" _

& vbNewLine _

& "Address = " & rCell.Offset(0, 1).Address(0, 0) _

& vbNewLine _

& "Value= " & rCell.Value _

& vbNewLine _

& "CF Formula= " & rCell.Offset(0, 1).FormatConditions.Item(1).Formula1, _

Buttons:=vbCritical, _

Title:="ERRORE")

End Sub

'---------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sDate As String

    Set Rng = Me.Range(sIndirizzo)

    Set Rng2 = Intersect(Rng, Target)

    sDate = Format(Date + 1, "dd/mm/yy")

    On Error GoTo XIT

    Application.EnableEvents = False

    Call Maiuscolo(Target)

    If Not Rng2 Is Nothing Then

        For Each rCell In Rng2.Cells

            With rCell

                With .Offset(0, 1).FormatConditions

                    If UCase(rCell.Value) = UCase(myFlag) Then

                        .Delete

                        .Add Type:=xlExpression, Formula1:= _

                                "=DATA.VALORE(" & Chr(34) & sDate & Chr(34) & ")=OGGI()"

                        .Item(1).Interior.Color = vbRed

                    ElseIf IsEmpty(rCell.Value) Then

                        .Delete

                    Else

                        Call MsgBox(Prompt:="Per favore, contrassegna la cella A con " _

                                            & "la sola X", _

                                    Buttons:=vbCritical, _

                                    Title:="CONTRAVENZIONE DELLE NORME!")

                        rCell.ClearContents

                        .Delete

                        Exit Sub

                    End If

                End With

            End With

        Next rCell

    End If

XIT:

    Application.EnableEvents = True

End Sub

'<<==========

Ora, quando il codice si blocca, per favore fammi sapere il contento del msgBox che riportera' l'errore.

===

Regards,

Norman

Answer 2

Salve ancora buona pasqua. Ho incollato il codice nuovo sul foglio "liquidi". Quando avvio la scrittura in minuscolo, mi compare questo messaggio: "ERRORE DI COMPILAZIONE - END SUB" e nel modulo mi evidenzia questo:

Private Sub Worksheet_Change(ByVal Target As Range) ======= (questo evidenziato giallo)

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sDate As String

[cut]

                        .Delete

                        .Add Type:=xlExpression, Formula1:= _

                             "=DATEVALUE(" & Chr(34) & sDate & Chr(34) & ")=TODAY()"

                        '"=DATA.VALORE(" & Chr(34) & sDate & Chr(34) & ")=OGGI()"

Nell' ultima stringa copiata trovo due linee che direbbero le stesse cose. E' corretto?

Grazie

Fabio

Ciao Fabio,

Le prima di queste due righe rappresenta la versione inglese (che io devo utilizzare) e la seconda riga è quella che tu dovresti usare con la versione italiana di Windows / Office. Nota, comunque l'apostrofo ad inizio della seconda riga, il quale istruisce VBA di ignorare la riga. Nel tuo caso, è necessario eliminare la prima riga e anche l'apostrofo iniziale della seconda di queste righe .

Detto questo, perché non stai utilizzando il codice postato nella mia ultima risposta che ha già corretto questo problema e un altro potenziale problema? Suggerirei pertanto di sostituire il vecchio codice con tale versione successiva.

===

Regards,

Norman

Answer 3

Salve ancora buona pasqua. Ho incollato il codice nuovo sul foglio "liquidi". Quando avvio la scrittura in minuscolo, mi compare questo messaggio: "ERRORE DI COMPILAZIONE - END SUB" e nel modulo mi evidenzia questo:

Private Sub Worksheet_Change(ByVal Target As Range) ======= (questo evidenziato giallo)

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sDate As String

    Set Rng = Me.Range(sIndirizzo)

    Set Rng2 = Intersect(Rng, Target)

    sDate = Format(Date + 1, "dd/mm/yy")

    On Error GoTo XIT

    Application.EnableEvents = False

    Call Maiuscolo(Target)

    If Not Rng2 Is Nothing Then

        For Each rCell In Rng2.Cells

            With rCell

                With .Offset(0, 1).FormatConditions

                    If UCase(rCell.Value) = UCase(myFlag) Then

                        .Delete

                        .Add Type:=xlExpression, Formula1:= _

                             "=DATEVALUE(" & Chr(34) & sDate & Chr(34) & ")=TODAY()"

                        '"=DATA.VALORE(" & Chr(34) & sDate & Chr(34) & ")=OGGI()"

Nell' ultima stringa copiata trovo due linee che direbbero le stesse cose. E' corretto?

Grazie

Fabio

Answer 4

Ciao Fabio,

Nella mia risposta, ho dimostrato come tutti i valori di testo minuscole su un foglio di lavoro potrebbero essere convertiti automaticamente in maiuscolo.

Tuttavia, la funzione Maiuscolo che ho fornito, prende un argomento Rng che consente che l'attività del codice sia limitato a uno o più intervalli sul foglio. Così, per esempio, se si volesse convertire solo i valori nell'intervallo A1:A20, il codice da incollare nel modulo di codice del foglio diventerebbe:

'==========>>

Option Explicit

'---------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim aRng As Range

    Const sAddress As String = "A1: A20"                     '<<==== Modifica

    Set aRng = Me.Range(sAddress)

    If Not Intersect(Target, aRng) Is Nothing Then

        On Error GoTo XIT

        Application.EnableEvents = False

        Call Maiuscolo(Target)

    End If

XIT:

    Application.EnableEvents = True

End Sub

'<<<=========

Per quanto riguarda il secondo esempio che ho postato, nel caso del tuo foglio LIQUIDI, se volessi limitare la conversione in maiuscolo ai due intervalli che stai utilizzando per immetere le X, il codice nel modulo di codice de quel foglio diventerebbe:

'==========>>

Option Explicit

Const sIndirizzo As String = "I37:I51, D52:D55"

Const myFlag As String = "X"

'---------->>

Private Sub Worksheet_Activate()

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sStr As String

    Dim aDate As String

    Dim iPos As Long

    Dim Res As Variant

    Dim blCondition As Boolean

    aDate = Format(Date, "dd/mm/yy")

    Set Rng = Me.Range(sIndirizzo)

    For Each rCell In Rng.Cells

        With rCell

            If UCase(.Value) = UCase(myFlag) Then

                With .Offset(0, 1).FormatConditions.Item(1)

                    blCondition = CBool(InStr(10, .Formula1, aDate, vbBinaryCompare))

                    If blCondition Then

                        If Not Rng2 Is Nothing Then

                            Set Rng2 = Union(Rng2, rCell)

                        Else

                            Set Rng2 = rCell

                        End If

                    End If

                End With

            End If

        End With

    Next rCell

    If blCondition Then

        Res = MsgBox(Prompt:="Attenzione vi sono parametri evidenziati." _

                             & vbNewLine _

                             & "sulle celle:" _

                             & vbNewLine & Rng2.Address(0, 0) & vbNewLine _

                             & "Vuoi deselezionarli?", _

                     Buttons:=vbYesNo, _

                     Title:="ATTENZIONE!")

        If Res = vbYes Then

            Application.EnableEvents = False

            With Rng2

                .ClearContents

                .Offset(0, 1).FormatConditions.Delete

            End With

            Application.EnableEvents = True

        End If

    End If

End Sub

'---------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sDate As String

    Set Rng = Me.Range(sIndirizzo)

    Set Rng2 = Intersect(Rng, Target)

    sDate = Format(Date + 1, "dd/mm/yy")

    On Error GoTo XIT

    Application.EnableEvents = False

       If Not Rng2 Is Nothing Then

         Call Maiuscolo(Rng2)

        For Each rCell In Rng2.Cells

            With rCell

                With .Offset(0, 1).FormatConditions

                    If UCase(rCell.Value) = UCase(myFlag) Then

                        .Delete

                        .Add Type:=xlExpression, Formula1:= _

                        "=DATA.VALORE(" & Chr(34) & sDate & Chr(34) & ")=OGGI()"

                        .Item(1).Interior.Color = vbRed

                    ElseIf IsEmpty(rCell.Value) Then

                        .Delete

                    Else

                        Call MsgBox(Prompt:="Per favore, contrassegna la cella A con " _

                                            & "la sola X", _

                                    Buttons:=vbCritical, _

                                    Title:="CONTRAVENZIONE DELLE NORME!")

                        rCell.ClearContents

                        .Delete

                        GoTo XIT

                    End If

                End With

            End With

        Next rCell

    End If

XIT:

    Application.EnableEvents = True

End Sub

'<<==========

Nota: Ho approfittato per corregere un problema potenziale nel codice della routine Worksheet_Activate, sostituendo la riga:

      Exit Sub

con

     GoTo XIT

===

Regards,

Norman

Answer 5

Buongiorno, ho trovato questa macro:

=========================================

Sub Uppercase()

   ' Loop to cycle through each cell in the specified range.

   For Each x In Range("A5")

      ' Change the text in the range to uppercase letters.

      x.Value = UCase(x.Value)

   Next

End Sub

===========================================

Purtroppo non mi si attiva in automatico. Come posso fare?

Ciao Fabio,

Fai clic dx sulla linguetta del foglio di interesse | Visualizza Codice |  e incolla il seguente codice:

'==========>>

Option Explicit

'---------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo XIT

    Application.EnableEvents = False

    Call Maiuscolo(Target)

XIT:

    Application.EnableEvents = True

End Sub

'<<<=========

Alt-IM per inserire un nuovo modulo di codice

Nel nuovo modulo vuoto, incolla il seguente codice:

'==========>>

Option Explicit

'---------->>

Public Function Maiuscolo(Rng As Range)

Dim Rng2 As Range

    Dim rCell As Range

    On Error Resume Next

     With Rng

      For Each rCell In Intersect(.Cells, _

                                    .SpecialCells(xlCellTypeConstants, 2))

            With rCell

            .Value = UCase(.Value)

            End With

        Next rCell

    End With

End Function

'<<==========

Alt-Q per chiudere l'editor di VBA

Nota, tuttavia, che si può avere solo una singola routine di Worksheet_Change in un determinato modulo di codice. Di conseguenza, se vi è una macro Worksheet_Change esistente, sarà necessario incorporare il codice Worksheet_Change suggerito sopra con il codice foglio esistente. Ad esempio, se volessi utilizzare il codice nel foglio LIQUIDI di cui abbiamo parlato in un altro thread, sarebbe necessario sostituire il codice nel modulo di codice di quel  foglio con la seguente versione:

'==========>>

Option Explicit

Const sIndirizzo As String = "I37:I51, D52:D55"         

Const myFlag As String = "X"                      

'---------->>

Private Sub Worksheet_Activate()

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sStr As String

    Dim aDate As String

    Dim iPos As Long

    Dim Res As Variant

    Dim blCondition As Boolean

    aDate = Format(Date, "dd/mm/yy")

    Set Rng = Me.Range(sIndirizzo)

    For Each rCell In Rng.Cells

        With rCell

            If UCase(.Value) = UCase(myFlag) Then

                With .Offset(0, 1).FormatConditions.Item(1)

                    blCondition = CBool(InStr(10, .Formula1, aDate, vbBinaryCompare))

                    If blCondition Then

                        If Not Rng2 Is Nothing Then

                            Set Rng2 = Union(Rng2, rCell)

                        Else

                            Set Rng2 = rCell

                        End If

                    End If

                End With

            End If

        End With

    Next rCell

    If blCondition Then

        Res = MsgBox(Prompt:="Attenzione vi sono parametri evidenziati." _

                             & vbNewLine _

                             & "sulle celle:" _

                             & vbNewLine & Rng2.Address(0, 0) & vbNewLine _

                             & "Vuoi deselezionarli?", _

                     Buttons:=vbYesNo, _

                     Title:="ATTENZIONE!")

        If Res = vbYes Then

            Application.EnableEvents = False

            With Rng2

                .ClearContents

                .Offset(0, 1).FormatConditions.Delete

            End With

            Application.EnableEvents = True

        End If

    End If

End Sub

'---------->>

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range, Rng2 As Range

    Dim rCell As Range

    Dim sDate As String

    Set Rng = Me.Range(sIndirizzo)

    Set Rng2 = Intersect(Rng, Target)

    sDate = Format(Date + 1, "dd/mm/yy")

On Error GoTo XIT

Application.EnableEvents = False

Call Maiuscolo(Target)

    If Not Rng2 Is Nothing Then

        For Each rCell In Rng2.Cells

            With rCell

                With .Offset(0, 1).FormatConditions

                    If UCase(rCell.Value) = UCase(myFlag) Then

                        .Delete

                        .Add Type:=xlExpression, Formula1:= _

                             "=DATEVALUE(" & Chr(34) & sDate & Chr(34) & ")=TODAY()"

                        '"=DATA.VALORE(" & Chr(34) & sDate & Chr(34) & ")=OGGI()"

                        .Item(1).Interior.Color = vbRed

                    ElseIf IsEmpty(rCell.Value) Then

                        .Delete

                    Else

                        Call MsgBox(Prompt:="Per favore, contrassegna la cella A con " _

                                            & "la sola X", _

                                    Buttons:=vbCritical, _

                                    Title:="CONTRAVENZIONE DELLE NORME!")

                        rCell.ClearContents

                        .Delete

                        Exit Sub

                    End If

                End With

            End With

        Next rCell

    End If

XIT:

Application.EnableEvents = True

End Sub

'<<==========

Qui ho incluso tutto il codice per il modulo di codice del foglio LIQUIDI per evitare eventuali problemi, ma ho evidenziato le modifiche in maiuscolo.

===

Regards,

Norman