Aide Macro

[safranien]

Bonjour à tous,

j'essaie de me lancer dans l'automatisation des tâches sous excel. J'y pige pas grand chose au langage encore et pour l'instant je passe par l'enregistreur de macro et je fouine par ci par là sur les forums d'excel-download.
Je cherche à créer un fichier "vierge" dans lequel je viendrais coller dans l'onglet "détail source" une extraction issue d'un logiciel.
Ces données ne sont pas figées (il peut dans le temps y avoir plus ou moins d'installations qui s'ajoutent ou s'enlevent).
Donc pour l'instant ma "macro" (det3) vient recopier les données de l'onglet "detail source" dans l'onglet "DETAIL", elle supprime les lignes dont les cellules de la colonne C contient les termes CP, CPC, PF, PFC et PFI, elle supprime les colonnes B, L, M, N, O et P, masque la colonne E, passe les lignes à une hauteur de 23, centre tout horizontalement et verticalement et aligne a gauche la colonne D (si vous pouviez me dire si déjà cette partie est pas trop mal faite?).

Et pour la suite, je sêche (voir onglet "DETAIL(2)"). A savoir:

je voudrais que pour toutes les lignes existantes (de A1 à J205) les cellules adjacentes (de K à R) soient "encadrées. Et que de K1 à R1, il y ait le titre "COMMENTAIRES" centré sur plusieurs colonnes et avec la même mise en forme que les autres cellules de titres. Sachant que derrière ça, il faut que je fasse des sous-totaux (ce qui m'amènera très certainement vers vous pour un autre problème).

Mais déjà si vous pouviez m'aiguiller pour ce premier probleme, ca serait sympa.

Merci a tous.

PS: le résultat final que je souhaite obtenir est l'onglet "DETAIL(3).

 

[safranien]

Re : Aide Macro

Bon, j'ai pas pu attendre demain.
Comment dire? Ca tue !!!!!!
Juste qques petits trucs qui se font pas très bien:

_ il y a beaucoup de cellules avec des nombres stockés sous format texte (pour les colonnes G, H et J). Ce qui fait que les sous totaux ne se font pas bien

_ sous la ligne des titres de colonnes (celle tout en bleu), je me retrouve avec deux sous totaux qui, bien sûr, sont à 0

_ A la place de Ecart% (colonne I) dans la ligne de titre il y a une erreur de calcul #VALEUR

_ La derniere ligne "TOTAL CENTRE DTH" (en bleu turquoise) se retrouve 1000 lignes après le tableau et juste en-dessous cette ligne il y a une autre ligne TOTAL (en jaune)

Mais sinon, ca colle avec cec que je cherche a faire.

Jevous laisse.

Bonne nuit.

 

[Minick]

Re : Aide Macro

Salut,

Il me faudrait les donnees que tu a utilise, parce que celle du fichier
d'origine ne posse pas ces problemes.

 

[safranien]

Re : Aide Macro

Salut,

je te joins le fichier.

Merci

 

[Minick]

Re : Aide Macro

Salut,

Forcement si c'est pas comme dans le post initiale ca coince un peu...

La correction d'apres le dernier fichier :

Sub Detail_Minick()
    Dim NbrLignes As Long, CptLignes As Long
    Dim MarchesExclus As String
    
    MarchesExclus = ";CP;CPC;PF;PFC;PFI;"
    
    With Sheets("DETAIL")
        Application.ScreenUpdating = False
        'Effacement des anciennes valeurs
        .Cells.Delete
        
        'Copie des colonnes de la source
        NbrLignes = Sheets("detail source").Range("C65526").End(xlUp).Row
        Sheets("detail source").Range("A13:A" & NbrLignes & ",C13:K" & NbrLignes).Copy .Range("A1")
        
        
        'Masquage de la colonne E
        .Columns("E").Hidden = True
        
        NbrLignes = .Range("A65526").End(xlUp).Row
        
        'Mise en numerique des valeurs
        .Range("K2:N" & NbrLignes).FormulaR1C1 = "=VALUE(RC[-4])"
        .Calculate
        .Range("G2:J" & NbrLignes).Value = .Range("K2:N" & NbrLignes).Value
        .Range("K2:N" & NbrLignes).ClearContents
        
        'Suppression des Marches Exclus
        For CptLignes = NbrLignes To 2 Step -1
            If InStr(1, MarchesExclus, ";" & UCase(.Range("B" & CptLignes).Value) & ";") <> 0 Then
                .Rows(CptLignes).Delete
                NbrLignes = NbrLignes - 1
            End If
        Next
        
        .Columns("A").ColumnWidth = 26
        .Columns("C").ColumnWidth = 14
        .Columns("D").ColumnWidth = 40
        
        'Centrage et hauteur des cellules
        With .Range("A1:J" & NbrLignes)
            .RowHeight = 26
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending, key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
        End With
        
        'Alignement a gauche de la colonne D
        .Range("D1" & NbrLignes).HorizontalAlignment = xlLeft
        
        'Mise en forme de la colonne commentaire
        .Range("A1:A" & NbrLignes).Copy
        With .Range("K1:R" & NbrLignes)
            .PasteSpecial Paste:=xlPasteFormats
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
        .Range("K1:R1").HorizontalAlignment = xlCenterAcrossSelection
        .Range("K1").Value = "Commentaires"
        
        'SOUS TOTAUX
        Application.DisplayAlerts = False
            NbrLignes = .Range("A65526").End(xlUp).Row
            .Range("A1:R" & NbrLignes).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            NbrLignes = .Range("A65526").End(xlUp).Row
            .Range("A1:R" & NbrLignes).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
        Application.DisplayAlerts = True
            
        'MFC
        With .UsedRange
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$A1;1)))")
                With .Font
                    .Bold = True
                    .Italic = False
                End With
                        
                .Interior.ColorIndex = 35
            End With
            
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$B1;1)))")
                .Interior.ColorIndex = 36
            End With
            
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""CENTRE DTH"";$D1;1)))")
                With .Font
                    .Bold = True
                    .Italic = False
                End With
                .Interior.ColorIndex = 33
            End With
        End With
        
        NbrLignes = .Range("A65526").End(xlUp).Row
        'Format cellules colonne Ecart%
        With .Range("I2:I" & NbrLignes)
            .NumberFormat = "[Red]0.00%;[Blue]-0.00%"
            .FormulaR1C1 = "=IF(RC[-1]=0,""-"",RC[1]/RC[-1])"
        End With
        
        'Mise en forme du total general
        With .Range("D" & NbrLignes)
            .Value = "TOTAL CENTRE DTH"
            .HorizontalAlignment = xlLeft
        End With
        .Range("A" & NbrLignes).Value = ""
        
        'Mise en forme des bordures des lignes de total
        For CptLignes = 2 To NbrLignes
            If .Range("B" & CptLignes).Value = "Total" Then
                .Rows(CptLignes).Delete
                CptLignes = CptLignes - 1
            ElseIf InStr(1, .Range("A" & CptLignes).Value, "Total") <> 0 _
                Or InStr(1, .Range("B" & CptLignes).Value, "Total") <> 0 Then
                .Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
                .Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
            
            ElseIf InStr(1, .Range("D" & CptLignes).Value, "TOTAL") <> 0 Then
                .Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
                .Range("A" & CptLignes & ":F" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
                .Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
            End If
        Next CptLignes
        
        'Ajout du titre et mise en forme
        .Rows(1).Insert
        .Range("A1").FormulaR1C1 = "=MID(CELL(""nomfichier""),FIND(""["",CELL(""nomfichier""))+1,FIND(""."",CELL(""nomfichier""))-FIND(""["",CELL(""nomfichier""))-1)"
        .Range("F1").Value = "DETAIL"
        
        .Range("A1:D1").HorizontalAlignment = xlCenterAcrossSelection
        .Range("F1:J1").HorizontalAlignment = xlCenterAcrossSelection
        
        With .Range("A1:D1,F1:J1")
            .VerticalAlignment = xlCenter
            .Borders.LineStyle = xlContinuous
            
            With .Font
                .Name = "Arial"
                .Size = 24
            End With
        End With
        
        'Mise en page
        With .PageSetup
            .LeftHeader = ""
            .CenterHeader = "&F"
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = "Page &P"
            .RightFooter = ""
            .LeftMargin = Application.CentimetersToPoints(0.4)
            .RightMargin = Application.CentimetersToPoints(0.4)
            .TopMargin = Application.CentimetersToPoints(1)
            .BottomMargin = Application.CentimetersToPoints(0.8)
            .HeaderMargin = Application.CentimetersToPoints(0.4)
            .FooterMargin = Application.CentimetersToPoints(0.4)
            .Orientation = xlLandscape
            .Zoom = 59
        End With

        Application.ScreenUpdating = True
    End With
End Sub

 

[safranien]

Re : Aide Macro

Oups...
ben en fait j'avais essayé d'alléger un max le fichier pour essayer de mettre un mix de plusieurs infos parce que 48 Ko c'est vite atteint.

Donc je m'excuse de t'avoir fait perdre du temps.

J'essaie tout ca demain.

Merci et bonne nuit.

tcho

 

[Staple1600]

Re : Aide Macro

Bonsoir

parce que 48 Ko c'est vite atteint.

C'est là qu'intervient la compression de fichier

Tu cliques-droit sur ton fichier Excel fermé et tu fais Envoyer vers -> Dossiers compressés -> Tu obtiens tonfichierExcel.zip
(c'est ce fichier qu'il faut poster sur le forum)

 

[safranien]

Re : Aide Macro

Bonjour Staple1600,

merci pour les conseils. Je m'y emploierai lors des prochains posts.

Cdt

 

[safranien]

Re : Aide Macro

Bonjour Minick.

Donc je viens de tester et ca a l'air de donner exactement ce que je cherchais a faire. J'ai juste modifié les lignes concernant la mise en forme de la colonne D car toute la colonne etait centree au lieu d etre alignee a gauche (OUAIIIIIS j'ai reussi a faire au moins ca lol )

Il reste seulement un truc. (Je joins le fichier)
Sur plusieurs lignes (48, 103,142 etc) il y a des erreurs #VALEUR ce qui fait que les sous totaux ne se calculent pas.
J'ai essayé d'insérer dans la macro une formule type "=SI(ESTERREUR etc..." sur les colonnes H,I et J pour supprimer les lignes qui comportent ces erreurs ou remplacer "#VALEUR" par "-" mais apparement j'ai tjrs pas bien saisi a quel endroit il faut que je le mette et surtout la mise en forme de l'ecriture dans la macro. Parce que je pense que c'est la formule pour convertir les nombres format texte en nombre qui fait ces #VALEUR (puisque dans le fichier source, il y a des "-" a la place de chiffres). Donc la je seche.

Et juste un autre dernier point
Dans la mise en page, est il possible de répéter la ligne de titres des colonnes sur chaque page?

Encore merci

 

[Staple1600]

Re : Aide Macro

Re


safranien:

autre conseil

Nettoies ton projet VBA

Tu as 4 modules qui sont vides.

Tu peux les supprimer.

 

[safranien]

Re : Aide Macro

Je viens de le faire.

Merci

(est ce que ca a un impact d'avoir des modules vides?)

 

[Minick]

Re : Aide Macro

Salut,

En rouge les corrections:

Sub Detail_Minick_3()
    Dim NbrLignes As Long, CptLignes As Long
    Dim MarchesExclus As String
    
    MarchesExclus = ";CP;CPC;PF;PFC;PFI;"
    
    With Sheets("DETAIL")
        Application.ScreenUpdating = False
        'Effacement des anciennes valeurs
        .Cells.Delete
        
        'Copie des colonnes de la source
        NbrLignes = Sheets("detail source").Range("C65526").End(xlUp).Row
        Sheets("detail source").Range("A13:A" & NbrLignes & ",C13:K" & NbrLignes).Copy .Range("A1")
        
        
        'Masquage de la colonne E
        .Columns("E").Hidden = True
        
        NbrLignes = .Range("A65526").End(xlUp).Row
        
        'Mise en numerique des valeurs
        [B][COLOR=Red].Range("K2:N" & NbrLignes).FormulaR1C1 = "=IF(RC[-4]=""-"",""-"",VALUE(RC[-4]))"[/COLOR][/B]
        .Calculate
        .Range("G2:J" & NbrLignes).Value = .Range("K2:N" & NbrLignes).Value
        .Range("K2:N" & NbrLignes).ClearContents
        
        'Suppression des Marches Exclus
        For CptLignes = NbrLignes To 2 Step -1
            If InStr(1, MarchesExclus, ";" & UCase(.Range("B" & CptLignes).Value) & ";") <> 0 Then
                .Rows(CptLignes).Delete
                NbrLignes = NbrLignes - 1
            End If
        Next
        
        .Columns("A").ColumnWidth = 26
        .Columns("C").ColumnWidth = 14
        .Columns("D").ColumnWidth = 40
        
        'Centrage et hauteur des cellules
        With .Range("A1:J" & NbrLignes)
            .RowHeight = 26
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Sort key1:=.Range("A1"), order1:=xlAscending, key2:=.Range("B1"), order2:=xlAscending, key3:=.Range("C1"), order3:=xlAscending, Header:=xlYes
        End With
        
        'Alignement a gauche de la colonne D
        .Range("D1:D" & NbrLignes).HorizontalAlignment = xlLeft
        .Range("D1").HorizontalAlignment = xlCenter
        
        
        'Mise en forme de la colonne commentaire
        .Range("A1:A" & NbrLignes).Copy
        With .Range("K1:R" & NbrLignes)
            .PasteSpecial Paste:=xlPasteFormats
            .Borders(xlInsideVertical).LineStyle = xlNone
        End With
        .Range("K1:R1").HorizontalAlignment = xlCenterAcrossSelection
        .Range("K1").Value = "Commentaires"
        
        'SOUS TOTAUX
        Application.DisplayAlerts = False
            NbrLignes = .Range("A65526").End(xlUp).Row
            .Range("A1:R" & NbrLignes).Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            NbrLignes = .Range("A65526").End(xlUp).Row
            .Range("A1:R" & NbrLignes).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(7, 8, 10), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
        Application.DisplayAlerts = True
            
        'MFC
        With .UsedRange
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$A1;1)))")
                With .Font
                    .Bold = True
                    .Italic = False
                End With
                        
                .Interior.ColorIndex = 35
            End With
            
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""Total"";$B1;1)))")
                .Interior.ColorIndex = 36
            End With
            
            With .FormatConditions.Add(Type:=xlExpression, Formula1:="=NON(ESTERREUR(CHERCHE(""CENTRE DTH"";$D1;1)))")
                With .Font
                    .Bold = True
                    .Italic = False
                End With
                .Interior.ColorIndex = 33
            End With
        End With
        
        NbrLignes = .Range("A65526").End(xlUp).Row
        'Format cellules colonne Ecart%
        With .Range("I2:I" & NbrLignes)
            .NumberFormat = "[Red]0.00%;[Blue]-0.00%"
            [B][COLOR=Red].FormulaR1C1 = "=IF(OR(RC[-1]=0,RC[-1]=""-""),""-"",RC[1]/RC[-1])"[/COLOR][/B]
        End With
        
        
        
        'Mise en forme du total general
        With .Range("D" & NbrLignes)
            .Value = "TOTAL CENTRE DTH"
            .HorizontalAlignment = xlLeft
        End With
        .Range("A" & NbrLignes).Value = ""
        
        'Mise en forme des bordures des lignes de total
        For CptLignes = 2 To NbrLignes
            If .Range("B" & CptLignes).Value = "Total" Then
                .Rows(CptLignes).Delete
                CptLignes = CptLignes - 1
            ElseIf InStr(1, .Range("A" & CptLignes).Value, "Total") <> 0 _
                Or InStr(1, .Range("B" & CptLignes).Value, "Total") <> 0 Then
                .Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
                .Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
            
            ElseIf InStr(1, .Range("D" & CptLignes).Value, "TOTAL") <> 0 Then
                .Range("A" & CptLignes & ":R" & CptLignes).Borders.LineStyle = xlContinuous
                .Range("A" & CptLignes & ":F" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
                .Range("K" & CptLignes & ":R" & CptLignes).Borders(xlInsideVertical).LineStyle = xlNone
            End If
        Next CptLignes
        
        'Ajout du titre et mise en forme
        .Rows(1).Insert
        .Range("A1").FormulaR1C1 = "=MID(CELL(""nomfichier""),FIND(""["",CELL(""nomfichier""))+1,FIND(""."",CELL(""nomfichier""))-FIND(""["",CELL(""nomfichier""))-1)"
        .Range("F1").Value = "DETAIL"
        
        .Range("A1:D1").HorizontalAlignment = xlCenterAcrossSelection
        .Range("F1:J1").HorizontalAlignment = xlCenterAcrossSelection
        
        With .Range("A1:D1,F1:J1")
            .VerticalAlignment = xlCenter
            .Borders.LineStyle = xlContinuous
            
            With .Font
                .Name = "Arial"
                .Size = 24
            End With
        End With
        
        'Mise en page
        With .PageSetup
            [B][COLOR=Red].PrintTitleRows = "$1:$1"[/COLOR][/B]
            .LeftHeader = ""
            .CenterHeader = "&F"
            .RightHeader = ""
            .LeftFooter = ""
            .CenterFooter = "Page &P"
            .RightFooter = ""
            .LeftMargin = Application.CentimetersToPoints(0.4)
            .RightMargin = Application.CentimetersToPoints(0.4)
            .TopMargin = Application.CentimetersToPoints(1)
            .BottomMargin = Application.CentimetersToPoints(0.8)
            .HeaderMargin = Application.CentimetersToPoints(0.4)
            .FooterMargin = Application.CentimetersToPoints(0.4)
            .Orientation = xlLandscape
            .Zoom = 59
        End With

        Application.ScreenUpdating = True
    End With
End Sub

 

[safranien]

Re : Aide Macro

Franchement, chapeau bas.

Tres impressionnant. Purée, je comprends pas 5% de ces codes et la logique d'ecriture grrrr

Mais je vais perseverer lol

Encore merci pour tout Minick. De ta patience, du temps consacré à mon projet.

Je vais maintenant me servir de cela pour faire les variantes que j'ai a faire. Donc logiquement je devrais plus t'embeter lol

Encore merci pour tout.

Bravo !!!!

 

[safranien]

Re : Aide Macro

J'ai une derniere question (promis apres j arrete lol)
J'ai crée dans la barre d'outil un menu pour acceder directement a cette macro. Le probleme c 'est que je retrouve ce menu dans n importe quel autre fichier excel que je peux ouvrir (meme si j'ai celui qui contient la macro qui est fermé).

Une idee?

 

[Minick]

Re : Aide Macro

Re,

Un exemple de ce que l'on peut faire.
Un menu perso s'ajoute a l'ouverture du fichier (a cote du ?), se masque
quand on change de fichier et 'se ferme' quand on quitte le fichier.

Il y a du code dans Thisworkbook.

 

[Staple1600]

Re : Aide Macro

Bonjour à tous

(est ce que ca a un impact d'avoir des modules vides?)

Déjà cela ne sert à rien

De plus cela alourdit ton fichier Excel

Donc plus ton fichier sera "mince" plus tu pourras le joindre facilement sur le forum.