XL 2021 VBA créer une ligne quand la cellule est > 0

ChloeVBA · 27 Juin 2023

Bonjour

J'ai un très long fichier pour lequel je souhaiterais intégrer une Macro :
Département 00800 00832 06282 Etc
0 0 0
32 0 25
0 0 72
L'objectif est de créer une nouvelle ligne à chaque montant différent de 0 et que ce montant soit recopié sur cette nouvelle ligne (sachant que parfois j'ai plusieurs montants sur une même ligne mais que j'ai besoin de créer 1 ligne à chaque montant, soit plusieurs nouvelles lignes pour chaque ancienne ligne). Et ensuite j'ai besoin d'ajouter sur chaque nouvelle ligne le nom de la colonne concernée :
de la colonne G à la colonne BB pour chaque cellule de la ligne différente de 0 créer une nouvelle ligne et copier la valeur sur cette nouvelle ligne
et ajouter en colonne F le nom de la colonne sur la nouvelle ligne

J'espère que c'est à peu près clair...

Merci mille fois à celui qui arrivera à solutionner mon casse-tête !

sylvanu · 28 Juin 2023

Re,
Dans la PJ précédente lorsqu'on appuie plusieurs fois sur le bouton on duplique les comptes.
Donc une version corrigée avec :

VB:

Sub Dispatch()
    Dim DL%, L%, C%
    Application.ScreenUpdating = False
    DL = Application.Max([B65500].End(xlUp).Row, [F65500].End(xlUp).Row)
    For L = DL To 4 Step -1
        If Cells(L, "B") <> "" Then
            For C = 7 To 54
                If Cells(L, C) > 0 And Cells(L, "F") <> "." Then
                    If Cells(L + 1, "F") <> Cells(3, C) Then
                        Rows(L + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Cells(L + 1, C) = Cells(L, C)
                        Cells(L + 1, "F") = Cells(3, C)
                    End If
                End If...

ChloeVBA · 27 Juin 2023

sylvanu · 28 Juin 2023

Bonjour Chloe, et bienvenue sur XLD,
Un essai en PJ avec :

VB:

Sub Dispatch()
    Dim DL%, L%, C%
    Application.ScreenUpdating = False
    DL = [B65500].End(xlUp).Row
    For L = DL To 4 Step -1
        For C = 7 To 54
            If Cells(L, C) > 0 Then
                Rows(L + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Cells(L + 1, C) = Cells(L, C)
                Cells(L + 1, "F") = Cells(3, C)
            End If
        Next C
    Next L
End Sub

Le bouton gris ne sert qu'à revenir au tableau de base pour faire des test.

sylvanu · 28 Juin 2023

Re,
Dans la PJ précédente lorsqu'on appuie plusieurs fois sur le bouton on duplique les comptes.
Donc une version corrigée avec :

VB:

Sub Dispatch()
    Dim DL%, L%, C%
    Application.ScreenUpdating = False
    DL = Application.Max([B65500].End(xlUp).Row, [F65500].End(xlUp).Row)
    For L = DL To 4 Step -1
        If Cells(L, "B") <> "" Then
            For C = 7 To 54
                If Cells(L, C) > 0 And Cells(L, "F") <> "." Then
                    If Cells(L + 1, "F") <> Cells(3, C) Then
                        Rows(L + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Cells(L + 1, C) = Cells(L, C)
                        Cells(L + 1, "F") = Cells(3, C)
                    End If
                End If
            Next C
            Cells(L, "F") = "."
        End If
    Next L
End Sub

Pour les lignes déjà traitées je mais un point en colonne F pour lever toute ambiguïté future.

ChloeVBA · 28 Juin 2023

sylvanu à dit:

Bonjour Chloe, et bienvenue sur XLD,
Un essai en PJ avec :

VB:

Sub Dispatch()
    Dim DL%, L%, C%
    Application.ScreenUpdating = False
    DL = [B65500].End(xlUp).Row
    For L = DL To 4 Step -1
        For C = 7 To 54
            If Cells(L, C) > 0 Then
                Rows(L + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Cells(L + 1, C) = Cells(L, C)
                Cells(L + 1, "F") = Cells(3, C)
            End If
        Next C
    Next L
End Sub

Le bouton gris ne sert qu'à revenir au tableau de base pour faire des test.

oh super merci beaucoup !!!!!

sylvanu · 28 Juin 2023

Re,
Attention, utilisez la V2, la V1 pose problème de duplication.

Cousinhub · 28 Juin 2023

Bonjour,
Une autre solution, utilisant Power Query (en natif dans ta version d'Excel)
Dans le fichier joint, 2 requêtes issues de ta base de données :
- Req1, qui restitue le tableau tel que tu le voulais dans la demande
- Req2, qui restitue tous les montants par département sur 1 colonne
Le Tableau Structuré de l'onglet "Base" se nomme "T_Data"
Pour mettre à jour, ruban "Données", "Actualiser tout"
Bonne apm

XL 2021 VBA créer une ligne quand la cellule est > 0

ChloeVBA

XLDnaute Nouveau

Pièces jointes

sylvanu

ChloeVBA

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

ChloeVBA

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Cousinhub

XLDnaute Barbatruc

Pièces jointes

Discussions similaires