Macro Copier polices en rouges

R2D2 · 20 Août 2009

Salut à tous,

Je cherche à extraire uniquement les données en polices rouges afin qu'elles soient copiées sur une autre feuille - les données sont sous MFC.
Ce fichier comprends +30 000 lignes car il évolue en permanence - j'ai essayé ce code mais sans succès, il plante au niveau du surlignement en rouge.

Sub copiePoliceRouge()
Dim Cel As Range
Dim rngRouge As Range
Set rngRouge = Nothing

Application.ScreenUpdating = False

For Each Cel In ActiveSheet.UsedRange
If Cel.Font.ColorIndex = 3 Then
If rngRouge Is Nothing Then
Set rngRouge = Cel
Else
Set rngRouge = Union(rngRouge, Cel)
End If
End If
Next
rngRouge.Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial xlAll, xlNone, False, False

Application.ScreenUpdating = True
End Sub [/PHP]

Si un novice à la réponse, une idée extra lumineuse pour me venir en aide, je lui en serais très reconnaissant.
Je mets le fichier à disposition en version légère.

Merci à tous pour votre aide

Robert · 20 Août 2009

Re : Macro Copier polices en rouges

Bonjour R2D2, bonjour le forum,

Bienvenu dans le forun puisque c'est ton premier post.

Tu ne peux pas utiliser la couleur d'encre rouge car c'est une mise en forme automatique, tu peux utiliser la formule qui rend cette couleur rouge. Dans ton cas si le numéro n'existe pas en colonne B :

Code:

Sub copiePoliceRouge()
Dim Cel As Range
Dim rngRouge As Range
 
Set rngRouge = Nothing
Application.ScreenUpdating = False
 
With Sheets("Pal S dep LM6 au 22 Dec")
    For Each Cel In .Range("A1:A" & Range("A65536").End(xlUp).Row)
        If .Columns(2).Find(Cel.Value, Range("B1"), xlValues, xlWhole) Is Nothing Then
        If rngRouge Is Nothing Then
                Set rngRouge = Cel
            Else
                Set rngRouge = Union(rngRouge, Cel)
            End If
        End If
    Next
End With
rngRouge.Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial xlAll, xlNone, False, False
Application.ScreenUpdating = True
End Sub

mromain · 20 Août 2009

Re : Macro Copier polices en rouges

bonjour R2D2 et bienvenue sur le forum,

le problème vient surement de la MFC.
bien que la MFC change la couleur du texte à l'affichage, la macro considère que tes données en colonne A sont de couleur noire (.Font.ColorIndex = -4105).
du coup, on ne passe jamais dans la boucle "If Cel.Font.ColorIndex = 3 Then", rngRouge = Nothing et le bug vient du "Nothing.Select" (rngRouge.Select).

a+

edit: bonjour Robert

R2D2 · 20 Août 2009

Re : Macro Copier polices en rouges

Ca marche feu de dieu !!! - il mets à peu près 5 mn pour passer en revue les 35000 lignes...mais C nickel Chrome !!!
Merci les gars....ça donne vraiment envie d'avoir votre niveau de connaissance ! - Chapeau les artistes...🙂

SubEndSub · 20 Août 2009

Re : Macro Copier polices en rouges

Bonjour chez vous

Une proposition utilisant la détection du format conditionnel
(en réutilisant le code de Robert)

Code:

Sub macro()
Dim Cel As Range, rngRouge As Range
Set rngRouge = Nothing
Application.ScreenUpdating = False
With ActiveSheet
    For Each Cel In .Range("A1:A" & Range("A65536").End(xlUp).Row)
        If ColourSorting(Cel, False, True) = 3 Then
        If rngRouge Is Nothing Then
                Set rngRouge = Cel
            Else
                Set rngRouge = Union(rngRouge, Cel)
            End If
        End If
    Next
End With
rngRouge.Copy
Sheets.Add
Selection.PasteSpecial xlAll, xlNone, False, False
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

code vba de bettersolutions.com

Code:

Public Function ColourSorting(ByVal rgeCell As Range, _
                              ByVal bBackGround As Boolean, _
                              ByVal bText As Boolean) As Integer

Dim iconditionno As Integer

   If rgeCell.FormatConditions.Count = 0 Then Exit Function
   iconditionno = ConditionNo(rgeCell)
   If bBackGround = True Then
      ColourSorting = rgeCell.FormatConditions(iconditionno).Interior.ColorIndex
   End If
   If bText = True Then
      ColourSorting = rgeCell.FormatConditions(iconditionno).Font.ColorIndex
   End If
End Function

Code:

Private Function ConditionNo(ByVal rgeCell As Range) As Integer

Dim iconditionscount As Integer
Dim objFormatCondition As FormatCondition

    For iconditionscount = 1 To rgeCell.FormatConditions.Count
        Set objFormatCondition = rgeCell.FormatConditions(iconditionscount)
        Select Case objFormatCondition.Type
           Case xlCellValue
               Select Case objFormatCondition.Operator
                   Case xlBetween: If Compare(rgeCell.Value, ">=", objFormatCondition.Formula1) = True And _
                                           Compare(rgeCell.Value, "<=", objFormatCondition.Formula2) = True Then _
                                           ConditionNo = iconditionscount
                      
                   Case xlNotBetween: If Compare(rgeCell.Value, "<=", objFormatCondition.Formula1) = True And _
                                           Compare(rgeCell.Value, ">=", objFormatCondition.Formula2) = True Then _
                                           ConditionNo = iconditionscount
   
                   Case xlGreater: If Compare(rgeCell.Value, ">", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
                       
                   Case xlEqual: If Compare(rgeCell.Value, "=", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
     
                   Case xlGreaterEqual: If Compare(rgeCell.Value, ">=", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
     
                   Case xlLess: If Compare(rgeCell.Value, "<", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
                       
                   Case xlLessEqual: If Compare(rgeCell.Value, "<=", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
                                                   
                   Case xlNotEqual: If Compare(rgeCell.Value, "<>", objFormatCondition.Formula1) = True Then _
                                           ConditionNo = iconditionscount
                                          
                  If ConditionNo > 0 Then Exit Function
              End Select

          Case xlExpression
            If Application.Evaluate(objFormatCondition.Formula1) Then
               ConditionNo = iconditionscount
               Exit Function
            End If
       End Select

    Next iconditionscount
End Function

Code:

Private Function Compare(ByVal vValue1 As Variant, _
                         ByVal sOperator As String, _
                         ByVal vValue2 As Variant) As Boolean
                       
   If Left(CStr(vValue1), 1) = "=" Then vValue1 = Range(Mid(CStr(vValue1), 2)).Value
   If Left(CStr(vValue2), 1) = "=" Then vValue2 = Range(Mid(CStr(vValue2), 2)).Value
                       
   If IsNumeric(vValue1) = True Then vValue1 = CDbl(vValue1)
   If IsNumeric(vValue2) = True Then vValue2 = CDbl(vValue2)
   
   Select Case sOperator
      Case "=": Compare = (vValue1 = vValue2)
      Case "<": Compare = (vValue1 < vValue2)
      Case "<=": Compare = (vValue1 <= vValue2)
      Case ">": Compare = (vValue1 > vValue2)
      Case ">=": Compare = (vValue1 >= vValue2)
      Case "<>": Compare = (vValue1 <> vValue2)
   End Select
End Function

Macro Copier polices en rouges

R2D2

Guest

Pièces jointes

Robert

XLDnaute Barbatruc

mromain

XLDnaute Barbatruc

R2D2

Guest

SubEndSub

XLDnaute Occasionnel

Discussions similaires

Macro Copier polices en rouges

R2D2

Guest

Pièces jointes

Robert

XLDnaute Barbatruc

mromain

XLDnaute Barbatruc

R2D2

Guest

SubEndSub

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency