Mettre en gras les séries de caractères entre quotes
Bonjour à tous !
Je souhaite mettre en gras les mots/groupes de mots (ou de chiffres) entre 2 quotes. Pouvez vous m'aider svp ? Je vous joins en attachement un exemple d'une longue liste que je souhaite mettre en forme avec cette condition. Merci de votre aide!
Bonjour izara booki, le forum,
Voici une solution par macro.
Cliquez sur le bouton 'Clic' et tous les caractères entre guillemets se mettront en gras. Bien sûr, il faut accepter les macros.
Votre classeur :
PS: veuillez préciser votre version d'Excel (ex : 2007, 2013, 365)
Cordialement.
AL 22
Bonjour à tous,
Vois ceci :
Sub test1()
Dim rng As Range, r As Range
With Sheets("Feuil1")
Set rng = .Range("c2", .Range("c" & Rows.Count).End(xlUp))
rng.Font.Bold = False
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = """(.+?)"""
For Each r In rng
If .test(r) Then
For Each m In .Execute(r)
r.Characters(m.firstindex + 2, m.Length - 2).Font.Bold = True
'r.Characters(m.firstindex + 2, m.Length - 2).Font.ColorIndex = 44
Next
End If
Next
End With
End With
End Sub
klin89
Bonjour,
Pour ne mettre qu'une partie du texte de chaque cellule il faut passer par le VBA. Ci-après une proposition et le code correspondant.
Option Explicit
Public Const QUOTATION_CHAR As String * 1 = """"
' UI button
Sub buttonClick()
Dim cell As Range
For Each cell In Selection
BoltQuotesInCell cell
Next cell
End Sub
' finding quotation marks
Private Function getQuotesIndexes(str As String) As Long()
Dim quotesIndexesList() As Long
ReDim quotesIndexesList(0 To 0)
Dim searchStart As Long
searchStart = 1
Dim lastQuoteIndex As Long
lastQuoteIndex = 0
If InStr(searchStart, str, QUOTATION_CHAR) = 0 Then
getQuotesIndexes = quotesIndexesList
Exit Function
End If
While searchStart < Len(str)
lastQuoteIndex = InStr(searchStart, str, QUOTATION_CHAR)
searchStart = lastQuoteIndex + 1
quotesIndexesList(UBound(quotesIndexesList)) = lastQuoteIndex
If lastQuoteIndex = 0 Then
searchStart = Len(str)
Else
ReDim Preserve quotesIndexesList(0 To UBound(quotesIndexesList) + 1)
End If
Wend
ReDim Preserve quotesIndexesList(0 To UBound(quotesIndexesList) - 1)
getQuotesIndexes = quotesIndexesList
End Function
' applying bolt effect on text
Private Sub BoltQuotesInCell(cell As Range)
Dim quotesIndexes() As Long
quotesIndexes = getQuotesIndexes(cell.Text)
Dim imax As Long
imax = UBound(quotesIndexes) + 1
If imax Mod 2 <> 0 Then
MsgBox "Quotations fermantes manquantes !"
Exit Sub
Else
Dim k As Long
For k = 0 To imax \ 2 Step 2
cell.Characters( _
Start:=quotesIndexes(k) + 1, _
Length:=quotesIndexes(k + 1) - quotesIndexes(k) - 1 _
).Font.FontStyle = "Bold"
Next k
End If
End Sub
'''''''''''''''''''''''''
' Test subs
'''''''''''''''''''''''''
Private Sub testIndexes()
Dim elt
For Each elt In getQuotesIndexes(ThisWorkbook.Worksheets(1).Range("c20").Text)
Debug.Print elt
Next elt
End Sub
Private Sub testHighlight()
BoltQuotesInCell ThisWorkbook.Worksheets(1).Range("C4")
End Sub
Merci à vous les gars pour vos réponses !
Problème résolu ! Le macro de ALL 22 fonctionne super bien, merci beaucoup. J'ai la version 2013.
Bonne journée à toutes et à tous!