Excel - дублирующиеся строки на основе содержимого ячейки

Question

У меня есть таблица с 600 строками. Каждая строка представляет от 2 до 12 географических объектов, каждый из которых имеет свой собственный ссылочный номер или «NGR».

Однако я хочу, чтобы каждая строка представляла только одну особенность. Таким образом, если бы в строке было 3 объекта, я бы хотел, чтобы 3 копии строки были изменены только с ссылочным номером NGR.

В итоге я хочу это:

Как оно сейчас

Изменено на это:

Как я этого хочу

Обратите внимание, как строки дублируются, но столбец NGR сохраняет уникальную ссылку.

Answer 1

Попробуйте добавить элемент управления нажатием кнопки и назначить макрос:

    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

Вы можете попробовать с этим сценарием и запустить 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

Вы можете сделать это с помощью Power Query - бесплатной надстройки от Microsoft для Excel 2010 или более поздней версии; и встроенный в Excel 2016 / Office 365, где он называется « Get & Transform (в Excel 2016; шаги, вероятно, аналогичны в 2010)

• Выберите Get&Transform из Table/Range
• В редакторе Power Query выберите столбец NGR
  • Разделить на разделитель (запятая)
• Затем выберите разделить столбцы (будет три или, может быть, больше)
• Отключить эти столбцы

Результаты с использованием ваших данных:

• Удалите новый столбец с меткой Attribute

• Переместите столбец со значениями NGR обратно в начало и переименуйте столбец.

Когда у вас есть новые данные, вы всегда можете повторно выполнить запрос для выполнения тех же операций.