Voici le code d’une procédure qui permet d’éliminer rapidement les espaces avant et après d’une chaîne de caractères.
Temps : 9 secondes pour un tableau de 20.600 lignes et 44 colonnes.
La procédure : TrimTable(ShtRng As Object, Optional ValueOnly As Boolean = False) As Range
Les arguments
ShtRng : de type Objet peut-être un objet WorkSheet ou un objet Range. Si l’objet est une feuille, la plage doit commencer en A1.
[ValueOnly] : FALSE (Défaut) conserve les formules, TRUE si on veut avoir uniquement les valeurs.
La syntaxe
La procédure peut être invoquée comme une fonction ou comme procédure SUB.
Quelques exemples
Avec l’argument ShtRng comme objet feuille (Ici l’argument ValueOnly est omis donc (False) par défaut.
TrimTable ThisWorkbook.Worksheets("Test_")
ou invoqué comme fonction avec l’argument ValueOnly à True
MsgBox TrimTable(ThisWorkbook.Worksheets("Test_"), True).Address
Avec l’argument ShtRng comme Objet Range.
rimTable ThisWorkbook.Worksheets("Test_").Range("B2:H5")
ou encore
TrimTable(ThisWorkbook.Worksheets("Test_").Range("B2:H5")).Interior.Color = vbYellow
Avec cellules non contigües
TrimTable ThisWorkbook.Worksheets("Test_").Range("$A$6:$A$9,$C$11:$C$13,$D$6:$D$7,$C$6,$D$15")
Avec les cellules sélectionnées
TrimTable Selection
Toutes les plages de cellules utilisées de la feuille
TrimTable ThisWorkbook.Worksheets("Test_").UsedRange
Le code de la procédure
Function TrimTable(ShtRng As Object, Optional ValueOnly As Boolean = False) As Range
' Supprime tous les espaces d'une chaîne de caractères à l'exception des espaces entre les mots
' Renvoie un objet Range
' Author : Philippe Tulliez
' Date : 20/06/2014 (v1 - 12/02/2012)
' Version 2.4
' Update
' 17/01/2013 - 2.0
' 19/01/2013 - 2.2 - Ajouté test ShtRng Is Nothing
' 2.3 - Affectation de TrimTable si ShtRng Is Nothing
' 20/06/2014 2.4 - Correction si ShtRng.Count = 1
' Arguments
' ShtRng - Object (WorkSheet ou Range)
' [ValueOnly] - Boolean si True transforme le résultat des formules en constante [d=False]
' Maximum 255 sélections de cellules non-contiguës
Const ErrTitle As String = "Procédure - TrimTable":
Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
Dim myTable() As Variant, wRow As Double, wColumn As Double
Dim area As Byte, Rng As Range, myRange As Range
Select Case True ' Test 1er argument
Case ShtRng Is Nothing ' 19/01/13
MsgBox ErrMsg & "Problème argument (ShtRng Non affecté)", vbCritical, ErrTitle
Set TrimTable = ActiveCell
Exit Function ' Sortie de procédure
Case TypeOf ShtRng Is Worksheet: Set Rng = ShtRng.Range("A1").CurrentRegion
Case TypeOf ShtRng Is Range ' 20/06/2014
If ShtRng.Count = 1 Then Set Rng = ShtRng.CurrentRegion Else Set Rng = ShtRng
Case Else
ErrMsg = ErrMsg & "Problème argument - ShtRng " & vbCrLf
MsgBox ErrMsg & "* Objet mal défini (WorkSheet) ou (Range)", vbCritical, ErrTitle
Set TrimTable = ActiveCell
Exit Function ' Sortie de procédure
End Select
For area = 1 To Rng.Areas.Count
Set myRange = Rng.Areas(area)
'
Select Case myRange.Count
Case 1 ' Une cellule
If ValueOnly Then myRange = Trim(myRange.Value) Else myRange = Trim(myRange.Formula)
Case Else
If ValueOnly Then myTable() = myRange.Value Else myTable() = myRange.Formula
For wRow = 1 To UBound(myTable, 1)
For wColumn = 1 To UBound(myTable, 2)
On Error Resume Next ' Si erreur renvoyée par une formule (ex #N/A)
myTable(wRow, wColumn) = Trim(myTable(wRow, wColumn))
On Error GoTo 0
Next wColumn
Next wRow
myRange = myTable()
End Select
Next area
Set TrimTable = Rng: Set Rng = Nothing: Set myRange = Nothing
End Function
Commentaires récents