Excel - Dupliquer les lignes en fonction du contenu d'une cellule

J'ai un tableur avec 600 lignes. Chaque ligne représente entre 2 et 12 entités géographiques, chacune avec son propre numéro de référence ou "NGR".

Je veux cependant que chaque ligne ne représente qu'une caractéristique. Donc, si une ligne avait 3 caractéristiques, je voudrais que 3 copies de la ligne avec uniquement le numéro de référence 'NGR' soient modifiées.

En résumé je veux ceci:

Comment c'est maintenant

Changé pour ceci:

Comment je le veux

Notez comment les lignes sont dupliquées, mais la colonne NGR conserve la référence unique.

Essayez d’ajouter un contrôle de clic de bouton et d’affecter la macro:

    Sub Button1_Click()
    Application.ScreenUpdating = False
    arr = Sheets(1).UsedRange
    a = 2
    For j = 2 To UBound(arr)
        If InStr(arr(j, 1), ",") > 0 Then
            brr = Split(arr(j, 1), ",")
            For i = 0 To UBound(brr)
                Cells(a, 1) = brr(i)
                For k = 2 To 4
                    Cells(a, k) = arr(j, k)
                Next k
                a = a + 1
            Next i
        Else
            For i = 1 To 4
                Cells(a, i) = arr(j, i)
            Next i
            a = a + 1
        End If
    Next j
    Application.ScreenUpdating = True
End Sub

Vous pouvez essayer avec ce script et exécuter DuplicateLine sous

Function getLastCell(pChamp As String)

    Dim LastColonne As Double
    Dim LastLigne As Double
    Dim vCurrentCell

    vCurrentCell = ActiveCell.Address

    ActiveCell.SpecialCells(xlLastCell).Select
    LastColonne = ActiveCell.Column
    LastColonne = LastColonne

    LastLigne = ActiveCell.Row
    LastLigne = LastLigne

    Range(vCurrentCell).Select

    If pChamp = "LINE" Then
        getLastCell = LastLigne
    ElseIf pChamp = "COLUMN" Then
        getLastCell = LastColonne
    Else
        getLastCell = "ERROR : Param LINE / COLUMN"
    End If


End Function

Function CutLine(pLine As Variant, pSeparator As String)
    Dim fields As Variant
    Dim vLine As Variant

    fields = Array()
    i = 0
    pos = 1
    vLine = pLine
    Do While pos <> 0
        pos = InStr(vLine, pSeparator)
        ReDim Preserve fields(i)
        If pos <> 0 Then
            fields(i) = Left(vLine, pos - 1)
            vLine = Mid(vLine, pos + Len(pSeparator))
        Else
            fields(i) = vLine
        End If
        i = i + 1
    Loop

    CutLine = fields
End Function

Function getElement(pString As String, pSeparator As String, pId As Double)

    vTab = CutLine(pString, pSeparator)

    getElement = vTab(pId - 1)
    'getElement = vTab(0)

End Function

Function getNbElement(pString As String, pSeparator As String)

    vTab = CutLine(pString, pSeparator)

    getNbElement = UBound(vTab) + 1

End Function

Function getLastElement(pString As String, pSeparator As String)

    vTab = CutLine(pString, pSeparator)

    getLastElement = vTab(UBound(vTab))

End Function

Function ColumnLetter(ColumnNumber As Double) As String


    If ColumnNumber <= 0 Then
        'negative column number
        ColumnLetter = ""

    ElseIf ColumnNumber > 16384 Then
        'column not supported (too big) in Excel 2007
        ColumnLetter = ""

    ElseIf ColumnNumber > 702 Then
        ' triple letter columns
        ColumnLetter = _
        Chr((Int((ColumnNumber - 1 - 26 - 676) / 676)) Mod 676 + 65) & _
        Chr((Int((ColumnNumber - 1 - 26) / 26) Mod 26) + 65) & _
        Chr(((ColumnNumber - 1) Mod 26) + 65)

    ElseIf ColumnNumber > 26 Then
        ' double letter columns
        ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                Chr(((ColumnNumber - 1) Mod 26) + 65)
    Else
        ' single letter columns
        ColumnLetter = Chr(ColumnNumber + 64)

    End If

End Function


Sub DuplicateLine()
Dim j As Double


    vMaxLigne = getLastCell("LINE")
    vNewLineId = vMaxLigne + 1
    For i = 2 To vMaxLigne
        vNbSite = Cells(i, 3)
        If vNbSite <> "" Then 'Manage Null Rows

            If vNbSite > 1 Then
                For j = 1 To vNbSite
                    'Copy Original Line
                    Rows(i & ":" & i).Copy
                    'Insert Original Line in New Line
                    Rows(vNewLineId & ":" & vNewLineId).Insert Shift:=xlDown
                    vNgr = getElement(Cells(i, 2), ", ", j)
                    Range("B" & vNewLineId).Value = vNgr

                    vNewLineId = vNewLineId + 1
                Next j
            End If
        End If
    Next i
    'Delete Original Line
    Rows(2 & ":" & vMaxLigne).Delete Shift:=xlUp

End Sub

Vous pouvez le faire avec Power Query - un complément gratuit de Microsoft pour Excel 2010 ou une version ultérieure; et intégré à Excel 2016 / Office 365 où il est appelé Get & Transform Vous simplement (dans Excel 2016; les étapes probablement similaires en 2010)

• Sélectionner Get&Transform de Table/Range
• Dans l'éditeur de requête de puissance, sélectionnez la colonne NGR
  • Séparer par délimiteur (virgule)
• Ensuite, sélectionnez les colonnes divisées (il y en aura trois ou peut-être plus)
• Découper ces colonnes

Résultats utilisant vos données:

• Supprimer la nouvelle colonne intitulée Attribute

• Déplacez la colonne avec les valeurs NGR au début et renommez la colonne.

Lorsque vous avez de nouvelles données, vous pouvez toujours réexécuter la requête pour effectuer les mêmes opérations.