XL 2016 Mise en forme VBA - recopie/décalage

Marjo2

XLDnaute Occasionnel
Bonjour,
Je viens vous redemander votre aide. J'ai voulu adapter une macro pour mise en forme mais je n'y arrive pas. Pour me former, vous serez t'il possible de mettre des commentaires dans les étapes de l'élaboration de la macro svp ?

J'ai inséré 2 colonnes en A
Ce qui est en gras, je les mis dans les colonne fraîchement ajouté mais 1 ligne en dessous
Supprimer les lignes vides
Recopie vers le bas jusqu'à la prochaine ligne en gras

En colonne C et D, si cellule avec du texte alors recopie vers le bas jusqu'à la prochaine non vide.
J'ai décalé de 2 colonnes vers la droite, ce qu'il y avait en format date (à partir de la date)
Je recopie vers le haut jusqu'à cellule non vide des colonnes C et D.

Le fichier comporte beaucoup beaucoup de lignes.

Merci d'avance.
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour marjo2,

Puisque "Le fichier comporte beaucoup beaucoup de lignes." pour aller vite il faut utiliser des tableaux VBA :
VB:
Private Sub Worksheet_Activate()
Dim ncol%, pas%, tablo, nlig&, resu(), i&, j&, w, x, y, z, k%, n&, col%, colk%
ncol = 19 'nombre de colonnes du tableau des résultats
pas = 7
tablo = Sheets("STOCK").[A1].CurrentRegion.Resize(, ncol) 'matrice, plus rapide
nlig = UBound(tablo)
ReDim resu(1 To nlig, 1 To ncol)
For i = 1 To nlig
    If IsDate(tablo(i, 1)) Then
        w = tablo(i - 1, 1): x = tablo(i - 1, 2)
        For j = i To nlig - pas + 1 Step pas
            If Not IsDate(tablo(j, 1)) Then i = j: Exit For
            y = tablo(j + 2, 1): z = tablo(j + 2, 2)
            For k = 0 To pas - 1
                n = n + 1
                resu(n, 1) = w
                resu(n, 2) = x
                resu(n, 3) = y
                resu(n, 4) = z
                For col = 5 To ncol
                    colk = IIf(k < 2, col - 4, col - 2)
                    resu(n, col) = tablo(j + k, colk)
        Next col, k, j
    End If
Next i
'--restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
With [A1] 'à adapter
    If n Then
        .Resize(n, ncol) = resu
        .Resize(n, 2).Font.Bold = True 'police en gras
    End If
End With
Columns.AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Mais bien sûr seules sont copiées les valeurs, pas les formats.

Fichier joint, la macro est dans le code de la feuille "Résultat" (clic droit sur l'onglet et Visualiser le code).

A+
 

Fichiers joints

Dernière édition:

job75

XLDnaute Barbatruc
On peut cependant appliquer des mises en forme partielles au fur et à mesure de l'avancement de la macro, voyez ce fichier (2) :
VB:
Private Sub Worksheet_Activate()
Dim ncol%, pas%, tablo, nlig&, resu(), i&, j&, w, x, y, z, k%, n&, col%, colk%
ncol = 19 'nombre de colonnes du tableau des résultats
pas = 7
tablo = Sheets("STOCK").[A1].CurrentRegion.Resize(, ncol) 'matrice, plus rapide
nlig = UBound(tablo)
ReDim resu(1 To nlig, 1 To ncol)
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
For i = 1 To nlig
    If IsDate(tablo(i, 1)) Then
        w = tablo(i - 1, 1): x = tablo(i - 1, 2)
        For j = i To nlig - pas + 1 Step pas
            If Not IsDate(tablo(j, 1)) Then i = j: Exit For
            y = tablo(j + 2, 1): z = tablo(j + 2, 2)
            For k = 0 To pas - 1
                n = n + 1
                '---mises en forme partielles---
                If k = 0 Then
                    Cells(n, 12).Resize(2).NumberFormat = "000"
                    Cells(n, 17).Resize(2).NumberFormat = "0.000"
                    Cells(n, 18).Resize(2, 2).NumberFormat = "0.000000"
                ElseIf k = 2 Then
                    Cells(n, 7).Resize(5).NumberFormat = "0.000"
                    Cells(n, 8).Resize(5, 2).NumberFormat = "0.000000"
                    Cells(n, 10).Resize(5, 2).NumberFormat = "0.00"
                    Cells(n, 7).Resize(5, 5).Font.Italic = True
                End If
                '---------------------------------
                resu(n, 1) = w
                resu(n, 2) = x
                resu(n, 3) = y
                resu(n, 4) = z
                For col = 5 To ncol
                    colk = IIf(k < 2, col - 4, col - 2)
                    resu(n, col) = tablo(j + k, colk)
        Next col, k, j
    End If
Next i
'--restitution---
With [A1] 'à adapter
    If n Then
        .Resize(n, ncol) = resu
        .Resize(n, 2).Font.Bold = True 'police en gras
    End If
End With
Columns.AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Cela prend évidemment plus de temps, pour tester j'ai recopié le tableau source sur 38 000 lignes.

Chez moi sur Win 10 - Excel 2013 :

- fichier (1) => 2,1 secondes

- fichier (2) => 7,5 secondes.

A+
 

Fichiers joints

Dernière édition:

Marjo2

XLDnaute Occasionnel
Sur l'exemple rendu ça fonctionne mais quand je copie mon export pour mettre au réel, ça ne fonctionne pas totalement.
La mise en forme est un plus merci.

Je me demande si l'erreur n'est pas dans PAS = 7 car je ne pense que c'est une valeur fixe, cela peut varier.

C'est à quel niveau qu'on recopie mais une ligne en dessous ?
Et le décalage de 2 vers la droite si format date ?

Merci
 

Fichiers joints

Marjo2

XLDnaute Occasionnel
Pas de soucis, merci de t'être penché sur mon problème.

Peut être avec un système de recherche pour pallier au pas.
 

Marjo2

XLDnaute Occasionnel
J'ai déjà une macro mais pas aussi poussé que celle demandé plus haut. Par contre cela fait la recopie sans avoir le pas. Il faut "juste" adapter le critère

Sub MiseEnForme()
Dim TData, TReport, TEntete
Dim i&, X&, TRw&, LstRow&
Dim ShData As Worksheet, ShReport As Worksheet
ReDim TEntete(3)
Set ShData = ThisWorkbook.Sheets("STOCK") 'feuille source
Set ShReport = ThisWorkbook.Sheets("Résultat") 'feuille de restitution
With ShData
LstRow = .Cells(.Rows.Count, 1).End(3).Row
TData = .Range(.Cells(1, 1), .Cells(LstRow, 15))
ReDim TReport(1 To UBound(TData, 1), 18)
End With
For i = LBound(TData, 1) To UBound(TData, 1)
If Left(TData(i, 1), 1) = "F" Then 'remplacer le F par une cellule texte qui n'a pas de point
For X = 1 To 3
TEntete(X) = TData(i, X)
Next X
Else
If Trim(TData(i, 14)) <> "" Then
TRw = TRw + 1
For X = 1 To 3
TReport(TRw, X) = TEntete(X)
Next X
For X = 4 To 18
TReport(TRw, X) = TData(i, X - 3)
Next X
End If
End If
Next i

ShReport.Cells(1, 1).Resize(TRw, UBound(TReport, 2)).FormulaLocal = TReport
End Sub
 

job75

XLDnaute Barbatruc
Bonjour Marjo2, le forum,

Bon voyez ce fichier (3) et cette macro qui fonctionne même quand le pas est variable :
VB:
Private Sub Worksheet_Activate()
Dim ncol%, tablo, nlig&, resu(), i&, w, x, y, z, j&, h&, hvide&, n&, col%, colj%
ncol = 19 'nombre de colonnes du tableau des résultats
tablo = Sheets("STOCK").[A1].CurrentRegion.Resize(, ncol) 'matrice, plus rapide
nlig = UBound(tablo)
ReDim resu(1 To nlig, 1 To ncol)
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
For i = 1 To nlig
    If tablo(i, 1) <> "" And Not IsDate(tablo(i, 1)) Then
        w = tablo(i, 1): x = tablo(i, 2)
    ElseIf IsDate(tablo(i, 1)) Then
        y = tablo(i + 2, 1): z = tablo(i + 2, 2)
        For j = i + 3 To nlig
            If tablo(j, 1) <> "" Then Exit For
        Next
        h = j - i: hvide = h - 2
        For j = 0 To h
            If j = h Then i = i + j - 1: Exit For
            n = n + 1
            '---mises en forme partielles---
            If j = 0 Then
                Cells(n, 12).Resize(2).NumberFormat = "000"
                Cells(n, 17).Resize(2).NumberFormat = "0.000"
                Cells(n, 18).Resize(2, 2).NumberFormat = "0.000000"
            ElseIf j = 2 Then
                    Cells(n, 7).Resize(hvide).NumberFormat = "0.000"
                    Cells(n, 8).Resize(hvide, 2).NumberFormat = "0.000000"
                    Cells(n, 10).Resize(hvide, 2).NumberFormat = "0.00"
                    Cells(n, 7).Resize(hvide, 5).Font.Italic = True
            End If
            '---------------------------------
            resu(n, 1) = w
            resu(n, 2) = x
            resu(n, 3) = y
            resu(n, 4) = z
            For col = 5 To ncol
                colj = IIf(j < 2, col - 4, col - 2)
                resu(n, col) = tablo(i + j, colj)
        Next col, j
    End If
Next i
'--restitution---
With [A1] 'à adapter
    If n Then
        .Resize(n, ncol) = resu
        .Resize(n, 2).Font.Bold = True 'police en gras
    End If
End With
Columns.AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Sur 38 000 lignes => 7,6 secondes, à peine plus qu'au post #4.

Bonne journée.
 

Fichiers joints

job75

XLDnaute Barbatruc
En colonne A il faut qu'il y ait 2 dates qui se suivent et non 5 comme sur la plage A9:A13.
 

job75

XLDnaute Barbatruc
Le fichier (4) est assez vicieux mais je pense que cette macro fonctionne dans tous les cas :
VB:
Private Sub Worksheet_Activate()
Dim ncol%, tablo, nlig&, resu(), i&, w, x, j&, h1&, h2%, y, z, n&, col%, colj%
ncol = 19 'nombre de colonnes du tableau des résultats
tablo = Sheets("STOCK").[A1].CurrentRegion.Resize(, ncol) 'matrice, plus rapide
nlig = UBound(tablo)
ReDim resu(1 To nlig, 1 To ncol)
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
Cells.Delete 'RAZ
For i = 1 To nlig
    If Not IsDate(tablo(i, 1)) And InStr(tablo(i, 1), ".") = 0 Then
        w = tablo(i, 1): x = tablo(i, 2)
    Else
        If tablo(i, 3) = "Stock début" Then
            j = i
        Else
            For j = i + 1 To nlig
                If Not IsDate(tablo(j, 1)) Or InStr(tablo(j, 1), ".") Then Exit For
            Next
        End If
        h1 = j - i
        h2 = 0
        y = "": z = ""
        If j <= nlig Then
            If tablo(j, 3) = "Stock début" Then h2 = 5
            If InStr(tablo(j, 1), ".") Then y = tablo(j, 1): z = tablo(j, 2)
        End If
        For j = 0 To h1 + h2
            If j = h1 + h2 Then i = i + j - 1: Exit For
            n = n + 1
            '---mises en forme partielles---
            If j = 0 And h1 Then
                Cells(n, 12).Resize(h1).NumberFormat = "000"
                Cells(n, 17).Resize(h1).NumberFormat = "0.000"
                Cells(n, 18).Resize(h1, 2).NumberFormat = "0.000000"
            ElseIf j = h1 And h2 Then
                Cells(n, 7).Resize(5).NumberFormat = "0.000"
                Cells(n, 8).Resize(5, 2).NumberFormat = "0.000000"
                Cells(n, 10).Resize(5, 2).NumberFormat = "0.00"
                Cells(n, 7).Resize(5, 5).Font.Italic = True
            End If
            '---------------------------------
            resu(n, 1) = w
            resu(n, 2) = x
            resu(n, 3) = y
            resu(n, 4) = z
            For col = 5 To ncol
                colj = IIf(j < h1, col - 4, col - 2)
                resu(n, col) = tablo(i + j, colj)
        Next col, j
    End If
Next i
'--restitution---
With [A1] 'à adapter
    If n Then
        .Resize(n, ncol) = resu
        .Resize(n, 2).Font.Bold = True 'police en gras
    End If
End With
Columns.AutoFit 'ajustement largeurs
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Vérifiez bien quand même.
 

Fichiers joints

Marjo2

XLDnaute Occasionnel
Merci Job75,
C'est presque ça.
De la ligne 111 à 121 il devrait y être inscrit en colonne C et D respectivement 1 et 100 idem de la ligne 151 à 154 avec 1 et 25.
Je pense que ça ne recopie pas jusqu'en haut car il y a un article en gras qui se répètent.

Je ne sais pas comment le traiter le plus facilement mais on peut faire que si l'article en colonne A et le même qu'au dessus alors on peut supprimer la ligne
(L'export excel du logiciel répète l'article car c'est une nouvelle page à l'impression)
 

job75

XLDnaute Barbatruc
Bonjour Marjo2,
De la ligne 111 à 121 il devrait y être inscrit en colonne C et D respectivement 1 et 100 idem de la ligne 151 à 154 avec 1 et 25.
Cela ne me paraît pas très cohérent mais si vous tenez à remplir les cellules vides des colonnes C et D il suffit d'ajouter :
VB:
'---remplissage des colonnes C et D vides---
For i = n - 1 To 1 Step -1
    If resu(i, 3) = "" Then resu(i, 3) = resu(i + 1, 3): resu(i, 4) = resu(i + 1, 4)
Next i
Fichier (5).

A+
 

Fichiers joints

Marjo2

XLDnaute Occasionnel
Toutes les cellules en C et D ne doivent pas être complétées. Certaines doivent restées vide. Par exemple l'article 2800700.
C'est pour cela que je proposais de supprimer la ligne dont le code en gras était inscrit plus haut
 

Marjo2

XLDnaute Occasionnel
Supprimer les doublons de la colonne A des articles en gras.
Comme ça la recopie vers le haut sera bien définie.
 

job75

XLDnaute Barbatruc
Testez ce fichier (6) avec ce nouveau code :
VB:
'---remplissage des colonnes C et D vides---
For i = n - 1 To 1 Step -1
    If resu(i, 3) = "" And resu(i, 1) = resu(i + 1, 1) Then resu(i, 3) = resu(i + 1, 3): resu(i, 4) = resu(i + 1, 4)
Next i
 

Fichiers joints

Marjo2

XLDnaute Occasionnel
Merci Job75, cela m'a l'air de fonctionner à merveille, tu as assuré, merci de ton aide.
 

Discussions similaires


Haut Bas