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

[ChloeVBA]

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 !

 

[ChloeVBA]

 

[sylvanu]

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

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]

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 :

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]

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

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]

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

 

[Cousinhub]

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