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.
 

Pièces jointes

  • Exemple IF.xlsm
    344.8 KB · Affichages: 10

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+
 

Pièces jointes

  • Exemple IF(1).xlsm
    349.4 KB · Affichages: 9
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+
 

Pièces jointes

  • Exemple IF(2).xlsm
    350.1 KB · Affichages: 11
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
 

Pièces jointes

  • Exemple IF(2) (1).xlsm
    417.5 KB · Affichages: 3

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.
 

Pièces jointes

  • Exemple IF(3).xlsm
    350.9 KB · Affichages: 5

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.
 

Pièces jointes

  • Exemple IF(4).xlsm
    462.5 KB · Affichages: 7

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+
 

Pièces jointes

  • Exemple IF(5).xlsm
    462.6 KB · Affichages: 9

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 847
dernier inscrit
Djigbenou