formattazione celle errata – Forum Excel VBA

Stai vedendo 8 articoli - dal 1 a 8 (di 8 totali)

Autore

Articoli

06/01/2026 alle 20:50 #54240 Score: 0 | Risposta

Partecipante

Karma: 1 pt

`
Private Sub cmdInvia_Click()

  Application.ScreenUpdating = False '<-- evita lo sfarfallìo del monitor


    Dim contatore As Long
    Dim rigaDebitore As Variant
    
If cboRicerca <> "" Then
MsgBox "Attenzione ! Record duplice", vbCritical, "Alert"
Call cmdReset_Click
    
    ActiveSheet.Cells(2, 2) = TxtCliente.Text
    Exit Sub
    
End If


  ' Seleziona la cella D2 e copia il suo contenuto (formula)
  Range("D2").Copy

  ' Incolla il contenuto nella cella immediatamente sopra (D2)
  Range("D2").PasteSpecial Paste:=xlPasteFormulas ' Incolla solo la formula
  ' Oppure usa Range("D2").PasteSpecial Paste:=xlPasteAll per incollare tutto (formula+formattazione)
  
  
  ' Rimuove la selezione "formica" (copia attiva)
  Application.CutCopyMode = False
  
  
  Dim ctl As Control

'per ogni controllo nella UserForm
For Each ctl In Me.Controls
    'se il controllo è una TextBox o ComboBox allora...
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
        'ad esclusione della ComboBox cboRicerca...
        If ctl.Name <> "cboRicerca" Then
            If Trim(ctl.Value) = "" Then
                MsgBox "Inserire " & ctl.Tag, vbExclamation, "Alert"
                ctl.SetFocus
                Exit Sub
            End If
        End If
    End If
Next ctl


contatore = TxtContatore.Value
    
    
    
    
    Dim arr() As Variant
    Dim r As Long, c As Long, nRows As Long, nCols As Long, k As Long
    Dim temp1 As Variant
    
    nRows = Cells(Rows.Count, "F").End(xlUp).Row
    nCols = 19
    ReDim arr(1 To (nRows + 1), 1 To nCols) As Variant
    
    For r = LBound(arr, 1) To nRows
        For c = LBound(arr, 2) To nCols
            arr(r, c) = Cells(r + 1, c).Value
        Next c
    Next r
    arr(nRows, 1) = contatore 'A
    arr(nRows, 2) = TxtCliente 'B
    arr(nRows, 3) = CDate(Format(TxtDataOper, "dd/mm/yy")) 'C
    arr(nRows, 5) = TxtMandato.Value 'E
    arr(nRows, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<-- da replicare
    arr(nRows, 8) = TxtDebOrigin.Value
    arr(nRows, 9) = TxtAccord.Value 'I
    arr(nRows, 10) = CboNumRate.Value 'J
    arr(nRows, 12) = TxtDaPag.Value 'L

    If ChkSiPag = True Then
        arr(nRows, 13) = "Si" 'M
    Else
        arr(nRows, 13) = "No"
    End If

    If ChkSiContab = True Then
        arr(nRows, 15) = "Si" 'O
    Else
        arr(nRows, 15) = "No"
    End If
 
    If TxtDirLiber = "S" Then
        arr(nRows, 16) = "Si" 'P
    Else
        arr(nRows, 16) = "No"
    End If
    
    arr(nRows, 17) = "No" 'Q
        
    Select Case TxtModalPag 'S
        Case 1
            arr(nRows, 19) = "Bonif"
        Case 2
            arr(nRows, 19) = "B_post"
        Case 3
            arr(nRows, 19) = "QrCode"
        Case Else
            arr(nRows, 19) = "null"
    End Select
    arr(nRows + 1, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<--replicato
        
    'Bubble Sort
    For r = 1 To UBound(arr, 1) - 2 Step 2
        For c = r + 2 To UBound(arr, 1) Step 2
            If UCase(arr(c, 2)) < UCase(arr(r, 2)) Then
                ReDim temp1(1 To 2, 1 To UBound(arr, 2))
                
                For k = 1 To UBound(arr, 2)
                    temp1(1, k) = arr(r, k)
                Next k
                temp1(2, 6) = arr(r + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(r, k) = arr(c, k)
                Next k
                arr(r + 1, 6) = arr(c + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(c, k) = temp1(1, k)
                Next k
                arr(c + 1, 6) = temp1(2, 6)
            End If
        Next c
    Next r
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For r = LBound(arr, 1) To UBound(arr, 1)
        Cells(r + 1, "A").Value = arr(r, 1)
        Cells(r + 1, "B").Value = arr(r, 2)
        Cells(r + 1, "C").Value = arr(r, 3)
        Cells(r + 1, "E").Value = arr(r, 5)
        Cells(r + 1, "F").Value = arr(r, 6)
        Cells(r + 1, "H").Value = arr(r, 8)
        Cells(r + 1, "I").Value = arr(r, 9)
        Cells(r + 1, "J").Value = arr(r, 10)
        Cells(r + 1, "L").Value = arr(r, 12)
        Cells(r + 1, "M").Value = arr(r, 13)
        Cells(r + 1, "O").Value = arr(r, 15)
        Cells(r + 1, "P").Value = arr(r, 16)
        Cells(r + 1, "Q").Value = arr(r, 17)
        Cells(r + 1, "S").Value = arr(r, 19)
    Next r
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Call cmdReset_Click
                
    On Error Resume Next
    rigaDebitore = Application.Match(contatore, ActiveSheet.Range("A:A"), 0)
    On Error GoTo 0
    
    If Not IsError(rigaDebitore) Then
        Range("B" & rigaDebitore).Select
    End If



    MsgBox "Inserimento effettuato con successo", vbInformation, "Avviso"
    
        TxtDataOper.SetFocus
        

End Sub`

Ho questo codice ma nelle colonne H (sempre), "I" ed "L" (queste ultime talvolta), dopo che inserisco i dati tramite userform, nel foglio dove vanno trascritti non sono formattati come numero ma mi esce l'avviso "il numero è formattato come testo o preceduto da un apostrofo".

Che devo fare ?

Se formatto le celle come "numero", la cosa risulta ininfluente

Grazie

07/01/2026 alle 8:56 #54241 Score: 0 | Risposta

LukeReds

Partecipante

Karma: 19 pts

ciao

se vuoi inserire un numero

r = Range("A" & Rows.Count).End(xlUp).Row

Range("A" & r + 1) = 1 * TextBox1

Dovrai controllare che quanto digitato nella textb0x1 sia un valore numerico

07/01/2026 alle 20:15 #54242 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

Dovrai controllare che quanto digitato nella textb0x1 sia un valore numerico

Ciao Luke e grazie per la tua risposta e disponibilità, ma non capisco cosa devo fare visto che non ho una Textbox chiamata "TextBox1" (le mie sono "TxtDebOrigin", "TxtAccord" e "TxtDaPag", e che le colonne dove le celle devono essere formattate in numero, sono "H", "I" ed "L", invece nel codice che mi suggerisci c'è scritto solo "Range" A

Appena puoi e vuoi, potresti spiegarmi come devo fare per favore ?

Grazie mille

08/01/2026 alle 12:52 #54243 Score: 0 | Risposta

LukeReds

Partecipante

Karma: 19 pts

ciao

scusa ma vcedo solo ora la tua domanda, nel post recedente ho solo fatto un esempio, basta sostituire A con la colonna dove vuoi inserire i numeri

08/01/2026 alle 19:56 #54244 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

ciao Luke (non so perchè non riesco a taggarti .... @nomeutente non mi funziona),

non devi scusarti di niente, ci mancherebbe pure.

Ho applicato il tuo suggerimento adeguando il range alle colonne di mio interesse; tutto ok tranne per la "H" che mi restituisce sempre l'avviso "il numero è formattato come testo o preceduto da un apostrofo".

Non so più che fare ... condivido il mio codice vba aggiornato


Private Sub cmdInvia_Click()

  Application.ScreenUpdating = False '<-- evita lo sfarfallìo del monitor


    Dim contatore As Long
    Dim rigaDebitore As Variant
    
If cboRicerca <> "" Then
MsgBox "Attenzione ! Record duplice", vbCritical, "Alert"
Call cmdReset_Click
    
    ActiveSheet.Cells(2, 2) = TxtCliente.Text
    Exit Sub
    
End If


  ' Seleziona la cella D2 e copia il suo contenuto (formula)
  Range("D2").Copy

  ' Incolla il contenuto nella cella immediatamente sopra (D2)
  Range("D2").PasteSpecial Paste:=xlPasteFormulas ' Incolla solo la formula
  ' Oppure usa Range("D2").PasteSpecial Paste:=xlPasteAll per incollare tutto (formula+formattazione)
  
  
  ' Rimuove la selezione "formica" (copia attiva)
  Application.CutCopyMode = False
  
  
  Dim ctl As Control

'per ogni controllo nella UserForm
For Each ctl In Me.Controls
    'se il controllo è una TextBox o ComboBox allora...
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
        'ad esclusione della ComboBox cboRicerca...
        If ctl.Name <> "cboRicerca" Then
            If Trim(ctl.Value) = "" Then
                MsgBox "Inserire " & ctl.Tag, vbExclamation, "Alert"
                ctl.SetFocus
                Exit Sub
            End If
        End If
    End If
Next ctl


contatore = TxtContatore.Value
    
    
    
    
    Dim arr() As Variant
    Dim r As Long, c As Long, nRows As Long, nCols As Long, k As Long
    Dim temp1 As Variant
    
    nRows = Cells(Rows.Count, "F").End(xlUp).Row
    nCols = 19
    ReDim arr(1 To (nRows + 1), 1 To nCols) As Variant
    
    For r = LBound(arr, 1) To nRows
        For c = LBound(arr, 2) To nCols
            arr(r, c) = Cells(r + 1, c).Value
        Next c
    Next r
    arr(nRows, 1) = contatore 'A
    arr(nRows, 2) = TxtCliente 'B
    arr(nRows, 3) = CDate(Format(TxtDataOper, "dd/mm/yy")) 'C
    arr(nRows, 5) = TxtMandato.Value 'E
    arr(nRows, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<-- da replicare
    arr(nRows, 8) = TxtDebOrigin.Value
    arr(nRows, 9) = TxtAccord.Value 'I
    arr(nRows, 10) = CboNumRate.Value 'J
    arr(nRows, 12) = TxtDaPag.Value 'L

    If ChkSiPag = True Then
        arr(nRows, 13) = "Si" 'M
    Else
        arr(nRows, 13) = "No"
    End If

    If ChkSiContab = True Then
        arr(nRows, 15) = "Si" 'O
    Else
        arr(nRows, 15) = "No"
    End If
 
    If TxtDirLiber = "S" Then
        arr(nRows, 16) = "Si" 'P
    Else
        arr(nRows, 16) = "No"
    End If
    
    arr(nRows, 17) = "No" 'Q
        
    Select Case TxtModalPag 'S
        Case 1
            arr(nRows, 19) = "Bonif"
        Case 2
            arr(nRows, 19) = "B_post"
        Case 3
            arr(nRows, 19) = "QrCode"
        Case Else
            arr(nRows, 19) = "null"
    End Select
    arr(nRows + 1, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<--replicato
        
    'Bubble Sort
    For r = 1 To UBound(arr, 1) - 2 Step 2
        For c = r + 2 To UBound(arr, 1) Step 2
            If UCase(arr(c, 2)) < UCase(arr(r, 2)) Then
                ReDim temp1(1 To 2, 1 To UBound(arr, 2))
                
                For k = 1 To UBound(arr, 2)
                    temp1(1, k) = arr(r, k)
                Next k
                temp1(2, 6) = arr(r + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(r, k) = arr(c, k)
                Next k
                arr(r + 1, 6) = arr(c + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(c, k) = temp1(1, k)
                Next k
                arr(c + 1, 6) = temp1(2, 6)
            End If
        Next c
    Next r
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For r = LBound(arr, 1) To UBound(arr, 1)
        Cells(r + 1, "A").Value = arr(r, 1)
        Cells(r + 1, "B").Value = arr(r, 2)
        Cells(r + 1, "C").Value = arr(r, 3)
        Cells(r + 1, "E").Value = arr(r, 5)
        Cells(r + 1, "F").Value = arr(r, 6)
        Cells(r + 1, "H").Value = arr(r, 8)
        Cells(r + 1, "I").Value = arr(r, 9)
        Cells(r + 1, "J").Value = arr(r, 10)
        Cells(r + 1, "L").Value = arr(r, 12)
        Cells(r + 1, "M").Value = arr(r, 13)
        Cells(r + 1, "O").Value = arr(r, 15)
        Cells(r + 1, "P").Value = arr(r, 16)
        Cells(r + 1, "Q").Value = arr(r, 17)
        Cells(r + 1, "S").Value = arr(r, 19)
    Next r
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Call cmdReset_Click
                
    On Error Resume Next
    rigaDebitore = Application.Match(contatore, ActiveSheet.Range("A:A"), 0)
    On Error GoTo 0
    
    If Not IsError(rigaDebitore) Then
        Range("B" & rigaDebitore).Select
    End If

r = Range("H" & Rows.Count).End(xlUp).Row
Range("H" & r + 1) = 1 * TextBox1

r = Range("I" & Rows.Count).End(xlUp).Row
Range("I" & r + 1) = 1 * TextBox1

r = Range("L" & Rows.Count).End(xlUp).Row
Range("L" & r + 1) = 1 * TextBox1


    MsgBox "Inserimento effettuato con successo", vbInformation, "Avviso"
    
        TxtDataOper.SetFocus
        

End Sub

09/01/2026 alle 9:04 #54246 Score: 0 | Risposta

LukeReds

Partecipante

Karma: 19 pts

ciao, bisognerebbe vedere anche il file, puoi allegarlo? Pochi dati please

10/01/2026 alle 21:18 #54255 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

Ciao Luke, eccolo

grazie

Allegati:

You must be logged in to view attached files.

11/01/2026 alle 9:00 #54259 Score: 0 | Risposta

LukeReds

Partecipante

Karma: 19 pts

non vedo la msgbox "il numero è formattato come testo o preceduto da un apostrofo"

Autore

Articoli

Stai vedendo 8 articoli - dal 1 a 8 (di 8 totali)