Как транспонировать повторяющиеся строки в столбцы в Excel?

Предположим, у вас есть диапазон данных в Excel, и вы хотите транспонировать повторяющиеся строки в несколько столбцов, как показано на следующем скриншоте. Есть ли у вас какие-либо хорошие идеи для решения этой задачи?

Транспонирование повторяющихся строк в столбцы с помощью кода VBA

Транспонирование повторяющихся строк в столбцы с помощью кода VBA

К сожалению, в Excel нет прямого способа справиться с этим, но вы можете создать код VBA для решения проблемы. Пожалуйста, выполните следующие действия:

1. Удерживайте клавиши ALT + F11, чтобы открыть окно Microsoft Visual Basic for Applications.

2. Нажмите Вставить > Модуль и вставьте следующий код в окно Модуля.

Код VBA: Транспонирование повторяющихся строк в несколько столбцов

Sub ConvertTable()
'Updateby Extendoffice
Dim xArr1 As Variant
Dim xArr2 As Variant
Dim InputRng As Range, OutRng As Range
Dim xRows As Long
xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
Set OutRng = OutRng.Range("A1")
xArr1 = InputRng.Value
t = UBound(xArr1, 2): xRows = 1
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 2 To UBound(xArr1, 1)
        If Not .exists(xArr1(i, 1)) Then
            xRows = xRows + 1: .Item(xArr1(i, 1)) = VBA.Array(xRows, t)
            For ii = 1 To t
                xArr1(xRows, ii) = xArr1(i, ii)
            Next
        Else
            xArr2 = .Item(xArr1(i, 1))
            If UBound(xArr1, 2) < xArr2(1) + t - 1 Then
                ReDim Preserve xArr1(1 To UBound(xArr1, 1), 1 To xArr2(1) + t - 1)
                For ii = 2 To t
                    xArr1(1, xArr2(1) + ii - 1) = xArr1(1, ii)
                Next
            End If
            For ii = 2 To t
                xArr1(xArr2(0), xArr2(1) + ii - 1) = xArr1(i, ii)
            Next
            xArr2(1) = xArr2(1) + t - 1: .Item(xArr1(i, 1)) = xArr2
        End If
    Next
End With
OutRng.Resize(xRows, UBound(xArr1, 2)).Value = xArr1
End Sub

3. Затем нажмите клавишу F5, чтобы запустить этот код, выберите диапазон данных, который вы хотите преобразовать из повторяющихся строк в несколько столбцов, в появившемся диалоговом окне, см. скриншот:

4. Нажмите OK и выберите ячейку, куда вы хотите поместить результат в следующем диалоговом окне, см. скриншот:

5. Затем нажмите кнопку OK, и ваши выбранные данные будут преобразованы следующим образом:

Раскройте магию Excel с Kutools AI

• Умное выполнение: Выполняйте операции с ячейками, анализируйте данные и создавайте диаграммы — всё это посредством простых команд.
• Пользовательские формулы: Создавайте индивидуальные формулы для оптимизации ваших рабочих процессов.
• Кодирование VBA: Пишите и внедряйте код VBA без особых усилий.
• Интерпретация формул: Легко разбирайтесь в сложных формулах.
• Перевод текста: Преодолейте языковые барьеры в ваших таблицах.

Улучшите возможности Excel с помощью инструментов на базе ИИ. Скачать сейчас и испытайте беспрецедентную эффективность!

Связанные статьи:

Как транспонировать / преобразовать столбцы и строки в одну строку?

Как транспонировать / преобразовать столбцы и строки в один столбец?

Как транспонировать / преобразовать один столбец в несколько столбцов в Excel?