XL 2013 Suppression des points de "milliers" de chiffres pour les transformer en nombre

onyirimba

XLDnaute Junior
Supporter XLD
Bonjour,

Je souhaiterai obtenir une Macro qui supprime les points de "de milliers" chiffres (voir IMAGE 1) pour qu'ils deviennent des nombre (voir IMAGE 3).
J'ai essayé avec le codage ci-après mais cela ne fonctionne pas, surtout avec la colonne J (voir IMAGE 2).

Sub Macro()
'
Cells.Select
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("H:H,J:J").Select
Range("J1").Activate
Selection.NumberFormat = "#,##0"
End Sub



Merci de votre aide.

Cordialement

IMAGE 1:
1633684456531.png



IMAGE 2:
1633684515816.png



IMAGE 3:
1633684544300.png
 

Pièces jointes

  • suppresion des points.xlsm
    19.9 KB · Affichages: 9

JHA

XLDnaute Barbatruc
Bonjour à tous,

Pourquoi ne pas sélectionner les colonnes intéressées et onglet "Accueil"/"Rechercher et sélectionner"/"Remplacer"
remplacer le point (mettre un . dans la fenêtre "rechercher") par la virgule (mettre , dans la fenêtre "remplacer par")

JHA
 

onyirimba

XLDnaute Junior
Supporter XLD
Bonjour à tous,

Pourquoi ne pas sélectionner les colonnes intéressées et onglet "Accueil"/"Rechercher et sélectionner"/"Remplacer"
remplacer le point (mettre un . dans la fenêtre "rechercher") par la virgule (mettre , dans la fenêtre "remplacer par")

JHA
Bonjour,

Parce que c'est une macro que je souhaite intégrer dans une autre macro beaucoup plus longue et il y a cette étape ou les points de "milliers de chiffres" doivent être supprimés
Et par conséquent le résultat de cette autre macro est erronée

Cordialement.
 

Dranreb

XLDnaute Barbatruc
Bonjour.
Je pense que je le ferais comme ça :
VB:
Option Explicit
Sub Essai()
   Dim R As Range, T()
   Set R = ActiveSheet.[C4:P4].Resize(ActiveSheet.[C4].End(xlDown).Row - 3)
   T = R.Value
   RemplaceStrDbl T, 6
   RemplaceStrCur T, 8
   RemplaceStrCur T, 12
   R.Offset(R.Rows.Count + 1).Value = T ' Provisoire, pour vérif.
'   r.value = t ' Instruction définitive
   End Sub
Sub RemplaceStrCur(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      Select Case VarType(T(L, C))
         Case vbString: T(L, C) = CCur(Replace(T(L, C), ".", ""))
         Case vbDouble: T(L, C) = CCur(T(L, C)): End Select
      Next L
   End Sub
Sub RemplaceStrDbl(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      If VarType(T(L, C)) = vbString Then T(L, C) = CDbl(Replace(T(L, C), ".", ""))
      Next L
   End Sub
 

onyirimba

XLDnaute Junior
Supporter XLD
Bonjour.
Je pense que je le ferais comme ça :
VB:
Option Explicit
Sub Essai()
   Dim R As Range, T()
   Set R = ActiveSheet.[C4:P4].Resize(ActiveSheet.[C4].End(xlDown).Row - 3)
   T = R.Value
   RemplaceStrDbl T, 6
   RemplaceStrCur T, 8
   RemplaceStrCur T, 12
   R.Offset(R.Rows.Count + 1).Value = T ' Provisoire, pour vérif.
'   r.value = t ' Instruction définitive
   End Sub
Sub RemplaceStrCur(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      Select Case VarType(T(L, C))
         Case vbString: T(L, C) = CCur(Replace(T(L, C), ".", ""))
         Case vbDouble: T(L, C) = CCur(T(L, C)): End Select
      Next L
   End Sub
Sub RemplaceStrDbl(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      If VarType(T(L, C)) = vbString Then T(L, C) = CDbl(Replace(T(L, C), ".", ""))
      Next L
   End Sub
Bonjour,

Merci beaucoup. Je regarde.

Cordialement.
 

onyirimba

XLDnaute Junior
Supporter XLD
Bonjour.
Je pense que je le ferais comme ça :
VB:
Option Explicit
Sub Essai()
   Dim R As Range, T()
   Set R = ActiveSheet.[C4:P4].Resize(ActiveSheet.[C4].End(xlDown).Row - 3)
   T = R.Value
   RemplaceStrDbl T, 6
   RemplaceStrCur T, 8
   RemplaceStrCur T, 12
   R.Offset(R.Rows.Count + 1).Value = T ' Provisoire, pour vérif.
'   r.value = t ' Instruction définitive
   End Sub
Sub RemplaceStrCur(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      Select Case VarType(T(L, C))
         Case vbString: T(L, C) = CCur(Replace(T(L, C), ".", ""))
         Case vbDouble: T(L, C) = CCur(T(L, C)): End Select
      Next L
   End Sub
Sub RemplaceStrDbl(T(), C As Integer)
   Dim L As Long
   For L = 1 To UBound(T, 1)
      If VarType(T(L, C)) = vbString Then T(L, C) = CDbl(Replace(T(L, C), ".", ""))
      Next L
   End Sub
Merci

est-ce que c'est possible que la Macro ne recopie pas les données en dessous de la Base de données existante mais juste remplace la base de données existante par la nouvelle base de données sans points au niveau des chiffres ?

Merci beaucoup

1633696980082.png
 

Dranreb

XLDnaute Barbatruc
Vous n'avez pas vu qu'il y avait une instruction provisoire juste pour vous permettre de vérifier que les données seront correctement remplacées tout en gardant sous les yeux l'original ?
Dans la version définitive réaffectez simplement T à R.Value.
 

onyirimba

XLDnaute Junior
Supporter XLD
Vous n'avez pas vu qu'il y avait une instruction provisoire juste pour vous permettre de vérifier que les données seront correctement remplacées tout en gardant sous les yeux l'original ?
Dans la version définitive réaffectez simplement T à R.Value.
Bonjour,

Lorsque j'essaie sur un fichier qui fait 15 200 lignes de longueur votre Macro ne fonctionne pas.
Savez vous résoudre ce problème ?

Merci d'avance
Cordialement
 

onyirimba

XLDnaute Junior
Supporter XLD
Peut être y a t-il une cellule vide en colonne C avant la fin des données ?
Si vous initialisez convenablement le Range R ça doit marcher sans problème.
bonjour,

J'ai ce message d'erreur qui apparait lorsque le fichier fait 15 200 lignes
J'ai joint le fichier : https://www.cjoint.com/c/KJpoci77cCe

est-ce que vous pouvez regarder ?

Merci d'avance.
Cordialement
1634306260184.png
 

Dranreb

XLDnaute Barbatruc
Je propose une autre écriture qui permettrait de trouver plus vite ce genre de cas :
VB:
Option Explicit
Sub Essai()
   Dim R As Range, T()
   Set R = ActiveSheet.[C4:P4].Resize(ActiveSheet.[C4].End(xlDown).Row - 3)
   RemplaceStrDbl R.Columns(6)
   RemplaceStrCur R.Columns(8)
   RemplaceStrCur R.Columns(12)
   End Sub
Sub RemplaceStrCur(ByVal R As Range)
   Dim T(), L As Long
   On Error Resume Next
   T = R.Value
   For L = 1 To UBound(T, 1)
      Err.Clear
      Select Case VarType(T(L, 1))
         Case vbString: T(L, 1) = CCur(Replace(T(L, 1), ".", ""))
            If Err Then
               Application.Goto R.Cells(L, 1)
               If MsgBox("""" & T(L, 1) & """ non convertible en Currency." _
                  & vbLf & Err.Description & vbLf & "Voulez-vous continuer ?", _
                  vbExclamation + vbYesNo, "RemplacerStrCur") = vbNo Then End
               End If
         Case vbDouble: T(L, 1) = CCur(T(L, 1)): End Select
      Next L
   R.Value = T
   End Sub
Sub RemplaceStrDbl(ByVal R As Range)
   Dim T(), L As Long
   On Error Resume Next
   T = R.Value
   For L = 1 To UBound(T, 1)
      Err.Clear
      Select Case VarType(T(L, 1))
         Case vbString: T(L, 1) = CDbl(Replace(T(L, 1), ".", ""))
            If Err Then
               Application.Goto R.Cells(L, 1)
               If MsgBox("""" & T(L, 1) & """ non convertible en Double." _
                  & vbLf & Err.Description & vbLf & "Voulez-vous continuer ?", _
                  vbExclamation + vbYesNo, "RemplacerStrDbl") = vbNo Then End
               End If
         Case vbCurrency: T(L, 1) = CDbl(T(L, 1)): End Select
      Next L
   R.Value = T
   End Sub
 

onyirimba

XLDnaute Junior
Supporter XLD
Je propose une autre écriture qui permettrait de trouver plus vite ce genre de cas :
VB:
Option Explicit
Sub Essai()
   Dim R As Range, T()
   Set R = ActiveSheet.[C4:P4].Resize(ActiveSheet.[C4].End(xlDown).Row - 3)
   RemplaceStrDbl R.Columns(6)
   RemplaceStrCur R.Columns(8)
   RemplaceStrCur R.Columns(12)
   End Sub
Sub RemplaceStrCur(ByVal R As Range)
   Dim T(), L As Long
   On Error Resume Next
   T = R.Value
   For L = 1 To UBound(T, 1)
      Err.Clear
      Select Case VarType(T(L, 1))
         Case vbString: T(L, 1) = CCur(Replace(T(L, 1), ".", ""))
            If Err Then
               Application.Goto R.Cells(L, 1)
               If MsgBox("""" & T(L, 1) & """ non convertible en Currency." _
                  & vbLf & Err.Description & vbLf & "Voulez-vous continuer ?", _
                  vbExclamation + vbYesNo, "RemplacerStrCur") = vbNo Then End
               End If
         Case vbDouble: T(L, 1) = CCur(T(L, 1)): End Select
      Next L
   R.Value = T
   End Sub
Sub RemplaceStrDbl(ByVal R As Range)
   Dim T(), L As Long
   On Error Resume Next
   T = R.Value
   For L = 1 To UBound(T, 1)
      Err.Clear
      Select Case VarType(T(L, 1))
         Case vbString: T(L, 1) = CDbl(Replace(T(L, 1), ".", ""))
            If Err Then
               Application.Goto R.Cells(L, 1)
               If MsgBox("""" & T(L, 1) & """ non convertible en Double." _
                  & vbLf & Err.Description & vbLf & "Voulez-vous continuer ?", _
                  vbExclamation + vbYesNo, "RemplacerStrDbl") = vbNo Then End
               End If
         Case vbCurrency: T(L, 1) = CDbl(T(L, 1)): End Select
      Next L
   R.Value = T
   End Sub
Je vous remercie
 

Discussions similaires

Réponses
11
Affichages
928
Haut Bas