Aide pour optimisation macro

[doublenico]

Bonjour,

J'ai crée une macro mais on ne peut pas dire qu'elle soit optimisée.
Je vous l'explique.
Dans mon tableau, j'ai une liste d'item qui appartiennent chacun à une catégorie. Juste à côté, j'ai une colonne 'type d'item' qui prend les valeurs suivantes : R,I,E,N ou vide.
Lorsque cette colonne, contient des items ou le type d'item est R,I,E,N, il copie ces items et les met dans une autre feuille du classeur selon l'ordre de classement.
Comme j'ai réussi à le faire pour un type d'item, j'ai fait des copiés/collés, pour les autres types d'items mais ma macro est res longue.


Merci

Ma macro se lance en cliquant sur le bouton 'filtre'

En fait,

Ci-joint la macro :
Sub filtre()

'

' Macro1 Macro
' Macro enregistrée le 29/06/2005 par u032332
'

' Effacer les résultats précédents

Sheets('Synthese').Select
Columns('B').Select
Selection.Delete Shift:=xlToLeft


Sheets('Synthese').Select
Cells(5, 3).Select
ActiveCell.FormulaR1C1 = 'Inducteurs clés'
Selection.Font.Bold = True
With Selection.Font
.Name = 'Arial'
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = 34


i = 9
j = 7
While i <= 109
Sheets('Cahierdescharges').Select
If Cells(i, 5) = 'I' Then
Cells(i, 4).Select
Selection.Copy
Sheets('Synthese').Select
Cells(j, 3).Select
ActiveSheet.Paste
j = j + 1
Else
End If
i = i + 1
Wend

jj1 = j + 2

Sheets('Synthese').Select
Cells(jj1, 3).Select
ActiveCell.FormulaR1C1 = 'Nouveautés majeures'
Selection.Font.Bold = True
With Selection.Font
.Name = 'Arial'
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = 34


k1 = j + 4

i = 9
While i <= 109
Sheets('Cahierdescharges').Select
If Cells(i, 5) = 'N' Then
Cells(i, 4).Select
Selection.Copy
Sheets('Synthese').Select
Cells(k1, 3).Select
ActiveSheet.Paste
k1 = k1 + 1
Else
End If
i = i + 1
Wend

k2 = k1 + 4

jj2 = k1 + 2

Sheets('Synthese').Select
Cells(jj2, 3).Select
ActiveCell.FormulaR1C1 = 'Engagements majeurs'
Selection.Font.Bold = True
With Selection.Font
.Name = 'Arial'
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = 34

i = 9
While i <= 109
Sheets('Cahierdescharges').Select
If Cells(i, 5) = 'E' Then
Cells(i, 4).Select
Selection.Copy
Sheets('Synthese').Select
Cells(k2, 3).Select
ActiveSheet.Paste
k2 = k2 + 1
Else
End If
i = i + 1
Wend

k3 = k2 + 4

jj3 = k2 + 2

Sheets('Synthese').Select
Cells(jj3, 3).Select
ActiveCell.FormulaR1C1 = 'Risques, points durs à surveiller'
Selection.Font.Bold = True
With Selection.Font
.Name = 'Arial'
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
End With
Selection.Interior.ColorIndex = 34

i = 9
While i <= 109
Sheets('Cahierdescharges').Select
If Cells(i, 5) = 'R' Then
Cells(i, 4).Select
Selection.Copy
Sheets('Synthese').Select
Cells(k3, 3).Select
ActiveSheet.Paste
k3 = k3 + 1
Else
End If
i = i + 1
Wend

Sheets('Synthese').Select
Columns('C:C').EntireColumn.AutoFit
Columns('C:C').Select
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With


Columns('C').Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

Columns('C:C').EntireColumn.AutoFit


Cells(5, 3).Select
Selection.HorizontalAlignment = xlCenter
Cells(jj1, 3).Select
Selection.HorizontalAlignment = xlCenter
Cells(jj2, 3).Select
Selection.HorizontalAlignment = xlCenter
Cells(jj3, 3).Select
Selection.HorizontalAlignment = xlCenter

Cells(1, 3).Select


End Sub
[file name=macro_20050928101156.zip size=22868]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/macro_20050928101156.zip[/file]

 

[Hervé]

Bonjour doublenico, le froum

une proposition en pièce jointe.

J'ai supprimé les cellules fusionnées de la feuille cahier des charges.

Evite d'utiliser ce système, ca fait pas bon ménage avec le VBA.

salut
[file name=macrov2.zip size=22439]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/macrov2.zip[/file]

 

[Hervé]

re

Je joins la macro ici, si c'est utile à quelqu'un :

Sub Bouton74_QuandClic()
Dim tablo() As String
Dim c As Range
Dim i As Byte, j As Byte, ligne As Byte, x As Byte

x = 1
ligne = 5

ReDim tablo(1 To 4, 1 To 1)
tablo(1, 1) = 'Inducteurs clés'
tablo(2, 1) = 'Nouveautés majeures'
tablo(3, 1) = 'Engagements majeurs'
tablo(4, 1) = 'Risques, points durs à surveiller'

For Each c In Range('c4:c' & Range('c65536').End(xlUp).Row)
    If c.Offset(0, 2) <> '' Then
        x = x + 1
        ReDim Preserve tablo(1 To 4, 1 To x)
        Select Case c.Offset(0, 2)
            Case 'I': tablo(1, UBound(tablo, 2)) = c
            Case 'N': tablo(2, UBound(tablo, 2)) = c
            Case 'E': tablo(3, UBound(tablo, 2)) = c
            Case 'R': tablo(4, UBound(tablo, 2)) = c
        End Select
    End If
Next c


With Sheets('synthese')
    .Columns(3).ClearFormats
    .Columns(3).ClearContents
   
    For i = 1 To UBound(tablo, 1)
        For j = 1 To UBound(tablo, 2)
            If tablo(i, j) <> '' Then
                .Cells(ligne, 3) = tablo(i, j)
                With .Cells(ligne, 3)
                    If j = 1 Then
                        .Interior.ColorIndex = 34
                        .HorizontalAlignment = xlCenter
                        .Font.Bold = True
                        .Font.Size = 14
                        .Font.Underline = xlUnderlineStyleSingle
                    Else
                        .Cells(ligne, 3).Interior.ColorIndex = 2
                    End If
                End With
                ligne = ligne + 1
            End If
        Next j
    Next i
End With
             
End Sub

salut

Message édité par: hervé, à: 28/09/2005 11:02

 

[doublenico]

Merci beaucoup !!!

Et quelle rapidité!!! :woohoo: