XL 2013 Résolu - VBA - Consolidation de données et mise en forme

[kaisermpt]

Bonjour,

je me permets de vous solliciter pour un problème de consolidation de résultats et de mise en forme.

J'ai des données que je dois consolider avec des informations identiques (références et catégorie).

Ces informations doivent être supprimées et reprises juste au-dessus.

Compte tenu du nombre de données (5000 lignes), je ne peux pas réaliser ces opérations manuellement.

Je vous transmets le fichier avec l'onglet de départ et l'onglet "Cible" où figure le résultat et la mise en forme souhaité.

Je précise que le nombre de lignes varie pour chaque référence.

Je reste à votre disposition pour tout complément d'information,

Cordialement

Sébastien

 

[zebanx]

Bonjour Kaisermpt,

Il n'y a qu'un seul onglet utilisé dans l'exemple... difficile de comprendre.

@+

 

[kaisermpt]

Oups..désolé ..avec le bon fichier..

 

[zebanx]

Re-

Ci-joint un fichier (mais je n'ai pas mis les bordures, sauf une ligne en plus gras à chaque changement et t'avoue ne pas savoir comment faire cette partie là !).
C'est une comparaison ligne à ligne donc il importe, comme tu l'as fait pour ce fichier, que les données soient triées.

@+
zebanx

 

[zebanx]

Testé sur 7000 lignes en à peu près 4 secondes.
Le code a changé sur un point : au lieu d'une feuille "départ" on part de la première feuille sheets(1).

@+

 

[kaisermpt]

Merci beaucoup pour ton aide.

Juste une question, si j'ai une colonne supplémentaire, afin que les données soient centrées sur les 5 colonnes au lieu de 4, à quel niveau je dois faire les modifications.

En te remerciant d'avance,

 

[zebanx]

Re-

Ca sera surement sur cette partie là, deux fois dans le code : With Range("C" & i & ":F" & i)
Mais ça dépend où tu insères les données.
Si c'est sur une colonne à supprimer (A et B actuellement), il faudra changer plus de bornes.
Si c'est après la colonne 3 du fichier de départ, qui sert à pas mal de passage dans le code, tu n'auras qu'à modifier la borne de fin "F" et ça devrait fonctionner.

@+
zebanx

Sub mef_tablo()
Dim derligne%, i%, t0

t0 = Timer
'--- suppression feuille "fin"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = Sheets.Count To 2 Step -1
If Sheets(i).Name = "fin" Then Sheets(i).Delete: Exit For
Next i

'--- ajout de lignes
derligne = Cells(Rows.Count, 1).End(3).Row
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = "fin"

derligne = Cells(Rows.Count, 1).End(3).Row

On Error Resume Next
For i = derligne To 2 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
Cells(i, 1).EntireRow.Insert (3)
Cells(i, 1).EntireRow.Insert (3)
End If
Next i

'--- ajout de textes pour chaque partie (colonne C = 3 = référence de recherche)
derligne = Cells(Rows.Count, 1).End(3).Row
For i = derligne To 2 Step -1
    If (Cells(i, 3) = "" And Cells(i - 1, 3) = "") Then
    Cells(i, 3) = Cells(i + 2, 2): Cells(i, 3) = Cells(i, 3)
    Cells(i - 1, 3) = Cells(i + 2, 1): Cells(i - 1, 3) = Cells(i - 1, 3)
    Else
    End If
Next i

'--- mise en forme (sur colonne D = 4 = vide)
For i = derligne To 2 Step -1
    If Cells(i, 4) = "" Then
        With Range("C" & i & ":F" & i) '--- ta demande : sur 4 colonnes : C, D, E et F donc si tu rajoutes une colonne, change tes bornes
        .MergeCells = True
        .HorizontalAlignment = xlCenter
        .FormatConditions.Delete
        .Interior.ColorIndex = 44
        .Interior.Pattern = xlSolid
        .Font.Bold = True
        End With
    End If
    If Cells(i, 3) Like "*-*" Then
        With Range("C" & i & ":F" & i)
        .Borders(xlEdgeTop).Weight = xlThick
        End With
    End If
Next i

'--- suppression colonnes A et B et enregistrement
Columns("A:B").Delete Shift:=xlToLeft
Call efface_shape
ActiveWorkbook.Save

Application.ScreenUpdating = True
MsgBox Format(Timer - t0, "0.000\sec")
End Sub

 

[kaisermpt]

Merci beaucoup pour ton aide. Çà me sera bien utile

@+

Seb