vba : extraire style et polices identiques

Question

Bonjour à tous,

Voilà, je travaille sur Excel en vba.

J'ai une feuille de calcul très longue avec des textes dans des styles ou polices différents.

Je souhaite, à l'aide d'une macro, récupérer tous ces textes de styles et polices identiques et les copier vers word.

Quelqu'un aurait il une idée ?

Peut être avec .SpecialCells(xlCellTypeSameFormatConditions)

D'avance merci

Afficher la suite

Lupin · Answer

Slt,

Voici un début de code !

Sub LocaliseStyle()
'
    Dim Boucle, Limite As Integer
    
    Limite = Range("A1").End(xlDown).Row
    
    For Boucle = 1 To Limite
        
        With Cells(Boucle, 1).Font
            If ((.Name = "Arial") And (.Size = 10)) Then
                MsgBox "Boucle = " & Boucle & " -> Style et police trouvé"
                ' Copier vers un autre feuille
                ' ou copier directement dans word par vba
                ' utiliser l'enregistreur de macro pour
                ' obtenir la syntaxe des objets.
            End If
        End With
    
    Next Boucle
    
End Sub

Lupin

Adam Pierson · Answer

Génial,

merci beaucoup.

Mais ton code s'arrête dès qu'une ligne est vide. Quelle paramètre dois je mettre dans limite pour qu'il aille plus bas et pas forcément qu'en colonne A ?

Désolé, mais je ne suis pas un pro du vba ;-)

Lupin · Answer

re:

Pour trouver la dernière ligne de la colonne A,
celle-ci est identifé par la lettre [A] de "A1"
Limite = Range("A1").End(xlDown).Row

Cette ligne ne sert qui si tu ignore à quel ligne
arrêter, et oui à la première celllule vide, il arrête.
*******************************************************************

Si tu veux valider les lignes de 10 à 100 indépendament
du contenu :

La ligne [ For Boucle = 1 To Limite ] deviendra [ For Boucle = 10 To 100 ]

Pour valider le style sur une cellule donnée, la ligne :

[ With Cells(Boucle, 1).Font ] défini quelle cellule !

Cells(Boucle,1) ->>> ou Boucle représente la ligne, et 1 la colonne.

Es-ce plus clair ainsi ?

Lupin

Lupin · Answer

re :

Voilà une approche différente !

1) Copier le code ci-dessous dans Excel
2) Lancer la macro [CreerBouton]
3) Sélectionner une plage contigu
4) Lancer le nouveau bouton
5) Sortie dans =>> "C:\Styles.doc"

Option Explicit
'
'Variables globale interne du module
Dim HWordApp As Variant
Dim hwdApp As Variant
Dim HCeDoc As Variant
'

Sub ExtraireStyle()

    'Définition de variables
    Dim Plage, Cellule As Range
    'Capture de la sélection
    Set Plage = ActiveWindow.RangeSelection
    Range("A1").Select
    'Pour chaque cellule de la plage
    Call OuvrirWord
    ActiveSheet.Select
    For Each Cellule In Plage
        Cellule.Select
        With Cellule.Font
            If ((.Name = "Arial") And (.Size = 10)) Then
                'MsgBox "Boucle = " & Boucle & " -> Style et police trouvé"
                Cellule.Copy
                HWordApp.Selection.Paste
            End If
        End With
    Next Cellule
    Application.CutCopyMode = False
    Call FermerWord
    
End Sub
'

Function OuvrirWord()
    'Config VBS
    On Error Resume Next
    Set HWordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set HWordApp = CreateObject("Word.Application")
    End If
    Err.Clear ' Efface l'objet Err
    HWordApp.Visible = True
    Set HCeDoc = HWordApp.Documents.Add
    HCeDoc.Selection

End Function
'

Function FermerWord()

    HWordApp.ActiveDocument.SaveAs ("C:\Styles.doc")
    HWordApp.Quit
    Set HCeDoc = Nothing
    Set HWordApp = Nothing

End Function
'

Sub CreerBouton()
    
    Dim MonCtr As Object
    
    With Application
      .CommandBars.Add(Name:="Essai1").Visible = True
      Set MonCtr = .CommandBars("Essai1").Controls.Add(Type:=msoControlButton, ID:=2950, Before:=1)
    End With
    MonCtr.OnAction = "ExtraireStyle"

End Sub

Lupin

Adam Pierson · Answer

Super génial le code.Merci beaucoup

Lupin · Answer

re :

Tout le plaisirs est pour moi :-)

J'avais déjà piloté Excel et Access depuis l'extérieur, mais
pas Word, alors j'ai profité de la situation pour aprofondire
le sujet.

Voilà j'ai encore amélioré mon code :-)

Option Explicit
Option Private Module
'
'Variables globale interne du module
Dim HWordApp As Variant
Dim HCeDoc As Variant
'

Sub ExtraireStyle()

    'Définition de variables
    Dim Plage, Cellule As Range
    Dim Reponse As Boolean
    'Capture de la sélection
    Set Plage = ActiveWindow.RangeSelection
    Range("A1").Select
    Reponse = OuvrirWord
    If (Reponse) Then
        ActiveSheet.Select
        'Pour chaque cellule de la plage
        For Each Cellule In Plage
            'Sélectionne la cellule
            Cellule.Select
            With Cellule.Font
                If ((.Name = "Arial") And (.Size = 10)) Then
                    'MsgBox "Adresse de cellule = " & .Adress & " -> Style et police trouvé"
                    'Copie le contenu dans le presse-papier
                    Cellule.Copy
                    'Colle dans Word
                    HWordApp.Selection.Paste
                End If
            End With
        Next Cellule
        Application.CutCopyMode = False
        Reponse = FermerWord
        If (Reponse) Then
            MsgBox "Traitement complété."
        Else
            MsgBox "Impossible de fermer Word."
        End If
    Else
        MsgBox "Impossible d'ouvrir Word."
    End If
    
End Sub
'

Function OuvrirWord() As Boolean
    
    'Config VBS
    On Error Resume Next
    Set HWordApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        Set HWordApp = CreateObject("Word.Application")
    End If
    Err.Clear ' Efface l'objet Err
    HWordApp.Visible = True
    Set HCeDoc = HWordApp.Documents.Add
    HCeDoc.Selection
    If (Err.Number <> 0) Then
        OuvrirWord = True
    Else
        OuvrirWord = False
    End If

End Function
'

Function FermerWord() As Boolean
    
    On Error GoTo Err_FermerWord
    HWordApp.ActiveDocument.SaveAs ("C:\Styles.doc")
    HWordApp.Quit
    Set HCeDoc = Nothing
    Set HWordApp = Nothing

Exit_FermerWord:
    FermerWord = True
    Exit Function

Err_FermerWord:
    FermerWord = False

End Function
'

Sub CreerBouton()
    
    Dim MonCtr As Object
    
    With Application
      .CommandBars.Add(Name:="Essai1").Visible = True
      Set MonCtr = .CommandBars("Essai1").Controls.Add(Type:=msoControlButton, ID:=2950, Before:=1)
    End With
    
    'MonCtr.OnAction = "NomDeModule.ExtraireStyle"
    MonCtr.OnAction = "ExtraireStyle"

End Sub

Vba : extraire style et polices identiques

6 réponses

Votre réponse

Discussions similaires

Newsletters