Excel - linhas duplicadas baseadas no conteúdo de uma célula

Question

Eu tenho uma planilha com 600 linhas. Cada linha representa entre 2 e 12 recursos geográficos, cada um com seu próprio número de referência ou 'NGR'.

No entanto, quero que cada linha represente apenas um recurso. Então, se uma linha tiver 3 recursos, eu quero 3 cópias da linha com apenas o número de referência 'NGR' alterado.

Em resumo, quero isto:

Como é agora

Alteradoparaisto:

Comoeuquero

Observe como as linhas são duplicadas, mas a coluna NGR mantém a referência exclusiva.

    

Answer 1

Tente adicionar um controle de clique de botão e atribua a 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

    

Answer 2

Você pode tentar com esse script e executar DuplicateLine sub

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

    

Answer 3

Você pode fazer isso com Power Query - um suplemento gratuito da Microsoft para o Excel 2010 ou posterior; e built-in para o Excel 2016 / Office 365, onde é chamado Get & Transform Você meramente (no Excel 2016; etapas provavelmente semelhantes em 2010)

• Selecione Get&Transform de Table/Range
• No Power Query Editor, selecione a coluna NGR
  • Divido por delimitador (vírgula)
• Em seguida, selecione as colunas divididas (haverá três ou talvez mais)
• Desvincular essas colunas

Resultados usando seus dados:

• Exclua a nova coluna chamada Attribute

• Mova a coluna com os valores NGR de volta ao início e renomeie a coluna.

Quando você tem novos dados, sempre é possível executar novamente a consulta para realizar as mesmas operações.