numeri con separatore migliaia

[FrasubbPartecipante Frasubb Karma: 1 pt]

Ciao a tutti, ho questo codice

Private Sub cmdInvia_Click()
    Dim contatore As Long
    Dim rigaDebitore As Variant
    Dim ctl As Control
    Dim arr() As Variant
    Dim r As Long, c As Long, nRows As Long, nCols As Long, k As Long
    Dim temp1 As Variant, regolarita As Variant
    Dim aziendaCedente As String, s As String
    Dim f As Range
    Dim wsFee As Worksheet
    
    If cboRicerca <> "" Then
        MsgBox "Attenzione ! Record duplice", vbCritical, "Alert"
        Call cmdReset_Click
        ActiveSheet.Cells(2, 2) = TxtCliente.Text
        Exit Sub
    End If
    
    '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
    
    Set wsFee = ThisWorkbook.Worksheets("FEE")
    Set f = wsFee.Columns("A").Find(What:=TxtMandato.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not f Is Nothing Then aziendaCedente = f.Offset(, 1).Value
    
    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 - 1
        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, 4) = aziendaCedente
    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) = TxtNumRate.Value 'J
    arr(nRows, 11) = TxtNumRate.Value 'K
    arr(nRows, 12) = TxtDaPag.Value 'L

    If ChkSiPag = True Then
        arr(nRows, 7) = "PAGATO" 'G
        arr(nRows, 13) = "Si" 'M
    Else
        arr(nRows, 7) = CLng(arr(nRows, 6)) - CLng(Date)
        arr(nRows, 13) = "No"
    End If
    
    If CboNumRate > 1 Then 'N
        arr(nRows, 14) = "PDR"
    Else
        arr(nRows, 14) = "UNI"
    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, 2) = TxtCodfisc.Value 'B - C.F. in seconda riga
    arr(nRows + 1, 3) = TxtTelefono.Text 'C - Nr. di telefono in seconda riga
    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, 2) = arr(r + 1, 2)
                temp1(2, 3) = arr(r + 1, 3)
                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, 2) = arr(c + 1, 2)
                arr(r + 1, 3) = arr(c + 1, 3)
                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, 2) = temp1(2, 2)
                arr(c + 1, 3) = temp1(2, 3)
                arr(c + 1, 6) = temp1(2, 6)
            End If
        Next c
    Next r
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    If nRows > 1 Then
        On Error Resume Next
        Range("A2:S" & nRows).ClearContents
        On Error GoTo 0
    End If
    
    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)
        If IsDate(arr(r, 3)) And InStr(arr(r, 3), "/") > 0 Then
            Cells(r + 1, "C").NumberFormat = "dd/mm/yy"
        Else
            Cells(r + 1, "C").NumberFormat = "General"
        End If
        Cells(r + 1, "C").Value = arr(r, 3)
        Cells(r + 1, "D").Value = arr(r, 4)
        Cells(r + 1, "E").Value = arr(r, 5)
        Cells(r + 1, "F").Value = arr(r, 6)
        Cells(r + 1, "G").Value = arr(r, 7)
        If Not IsEmpty(arr(r, 8)) And IsNumeric(arr(r, 8)) Then
            Cells(r + 1, "H").NumberFormat = "0.00"
            s = arr(r, 8)
            s = Replace(s, ".", Application.DecimalSeparator)
            s = Replace(s, ",", Application.DecimalSeparator)
            Cells(r + 1, "H").Value = CDbl(s)
        Else
            Cells(r + 1, "H").NumberFormat = "@"
        End If
        
        If Not IsEmpty(arr(r, 9)) And IsNumeric(arr(r, 9)) Then
            Cells(r + 1, "I").NumberFormat = "0.00"
            s = arr(r, 9)
            s = Replace(s, ".", Application.DecimalSeparator)
            s = Replace(s, ",", Application.DecimalSeparator)
            Cells(r + 1, "I").Value = CDbl(s)
        Else
            Cells(r + 1, "I").NumberFormat = "@"
        End If
        
        Cells(r + 1, "J").Value = arr(r, 10)
        Cells(r + 1, "K").Value = arr(r, 11)
        
        If Not IsEmpty(arr(r, 12)) And IsNumeric(arr(r, 12)) Then
            Cells(r + 1, "L").NumberFormat = "0.00"
            s = arr(r, 12)
            s = Replace(s, ".", Application.DecimalSeparator)
            s = Replace(s, ",", Application.DecimalSeparator)
            Cells(r + 1, "L").Value = CDbl(s)
        Else
            Cells(r + 1, "L").NumberFormat = "@"
        End If
        
        Cells(r + 1, "M").Value = arr(r, 13)
        Cells(r + 1, "N").Value = arr(r, 14)
        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, "R").Value = arr(r, 18)
        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"
    
    TxtContatore.SetFocus
End Sub

ma quando gli importi che la user va a trasferire nelle colonne H, I, L non sono formattati col separatore delle migliaia.

In poche parole, avrei bisogno che siano in questo formato: xx.xxx,xx

 

[alexps81Moderatore alexps81 Karma: 56 pts]

Prova così, modifica il codice in questi punti:

.......
.......
Cells(r + 1, "H").NumberFormat = "#,##0.00"
.......
.......
Cells(r + 1, "I").NumberFormat = "#,##0.00"
.......
.......
Cells(r + 1, "L").NumberFormat = "#,##0.00"
.......
.......

P.S. consiglio di formattare le TextBox in modo tale che mentre si scrive si compilano in automatico con "€ XX.XXX,XX"

Ovviamente da trattare in discussione diversa da questa.

[FrasubbPartecipante Frasubb Karma: 1 pt]

@alexps81 a dir poco perfetto come sempre, grazie mille, chiudo 

[Autore]

Articoli