Public Sub add_In_menucell()
With CommandBars("Cell")
.Reset
Set pop1 = .Controls.Add(msoControlPopup, Before:=1): pop1.Caption = "change le format"
Set pop2 = .Controls.Add(msoControlPopup, Before:=2): pop2.Caption = "appliquer un trim"
With pop1
Set bt = .Controls.Add(msoControlButton): bt.Caption = "Majuscule": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """UPPER""" & "'"
Set bt = .Controls.Add(msoControlButton): bt.Caption = "Minuscule": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """LOWER""" & "'"
Set bt = .Controls.Add(msoControlButton): bt.Caption = "nom Propre": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """PROPER""" & "'"
End With
With pop2
Set bt = .Controls.Add(msoControlButton): bt.Caption = "Left Trim(justify left)": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """LTRIM""" & "'"
Set bt = .Controls.Add(msoControlButton): bt.Caption = "Left Right Trim": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """TRIM""" & "'"
Set bt = .Controls.Add(msoControlButton): bt.Caption = "right Trim": bt.OnAction = "'ChangeAllCellpropertiestextInRange " & """RTRIM""" & "'"
End With
End With
End Sub
Public Sub restmenuCXell()
CommandBars("Cell").Reset
End Sub
Public Function ChangeAllCellpropertiestextInRange(prop As String)
'MsgBox prop
Dim R As Variant, Addr, RnG As Range
Set RnG = Selection
With RnG
Addr = "'" & .Parent.Name & "'!" & .Address(0, 0)
Select Case UCase(prop)
'formule non matricielles
Case "LOWER", "UPPER", "PROPER"
R = Evaluate("IF(ISTEXT(" & Addr & ")," & UCase(prop) & "(" & Addr & "),REPT(" & Addr & ",1))")
'formules matricielle
Case "LTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),MID(" & Addr & ",FIND(MID(TRIM(" & Addr & "),1,2)," & Addr & ",1),LEN(" & Addr & ")),REPT(" & Addr & ",1))")
'ancienne formule RTRIM qui fonctionne sur 2007
'Case "RTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),LEFT(" & Addr & ",FIND(""^^"",SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""^^"",LEN(" & Addr & ")-LEN(SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""""))))),REPT(" & .Address & ",1))")
'nouvelle formule 2013 2016 2019
Case "RTRIM": R = Evaluate("IF(ISTEXT(" & Addr & "),LEFT(" & Addr & ",FIND(""§"",SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""§"",LEN(" & Addr & ")-LEN(SUBSTITUTE(" & Addr & ",RIGHT(TRIM(" & Addr & "),1),""""))),1))," & Addr & ")")
Case "TRIM": .Value = Evaluate("IF(ISTEXT(" & Addr & "),MID(" & Addr & ",FIND(MID(TRIM(" & Addr & "),1,2)," & Addr & ",1),LEN(" & Addr & ")),REPT(" & Addr & ",1))")
R = Evaluate("IF(ISTEXT(" & Addr & "),MID(" & Addr & ",1,FIND(TRIM(RIGHT(SUBSTITUTE(TRIM(" & Addr & "), "" "", REPT("" "", 100)), 100))," & Addr & ",1)+LEN(TRIM(RIGHT(SUBSTITUTE(TRIM(" & Addr & "), "" "", REPT("" "", 100)), 100)))-1),REPT(" & Addr & ",1))")
End Select
End With
Selection = R
End Function