Vba : extraire style et polices identiques

Adam Pierson -
Lupin - 14 déc. 2005 à 14:11

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

A voir également:

Vba : extraire style et polices identiques
Excel compter cellule couleur sans vba - Guide
Incompatibilité de type vba ✓ - Forum VB / VBA
Erreur 13 incompatibilité de type VBA excel ✓ - Forum Excel
Mkdir vba ✓ - Forum VB / VBA
Dépassement de capacité vba ✓ - Forum Excel

6 réponses

Réponse 1 / 6

Lupin

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

Réponse 2 / 6

Adam Pierson

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 ;-)

Réponse 3 / 6

Lupin

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

Réponse 4 / 6

Lupin

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

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question

Réponse 5 / 6

Adam Pierson

Super génial le code.

Merci beaucoup

Réponse 6 / 6

Lupin

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

Discussions similaires

"L'indice n'appartient à la sélection" + VBA

Erreur d'exécution 13 Incompatibilité de type

appliquer une pause dans une macro vba excel

ouverture d'un fichier excel à partir d'un code VBA

Méthode find dans VBA - Recherche de données sous Excel

Votre réponse

Discussions similaires