Excel VBA транспонировать и дублировать заголовки

Question

У меня есть лист Excel, похожий на приведенный ниже

    A        B       C
   1 name   company address
   2 john   apple   london
   3 jack   microsoft   kent
   4 ahmed  spacex  ca

, но мне нужно преобразовать его в приведенный ниже

    A
   1 name
   2 john
   3 company
   4 apple
   5 address
   6 london
   7 name
   8 jack
   9 company
   10 microsoft
   11 address
   12 kent
   13 name
   14 ahmed
   15 company
   16 spacex
   17 address
   18 ca

как этого можно добиться с помощью VBA?кажется, что главная проблема заключается в дублировании заголовков, таких как имя, поскольку каждое имя должно иметь заголовок над всем этим в одном столбце, любая помощь будет принята с благодарностью.

Answer 1

Предполагая, что ваш пример (в вашем посте) находится на листе с именем "Sheet2", код попытается вывести транспонированный массив в столбец E (поэтому вы можете сохранить / сделать копию перед запуском).

Option Explicit

Private Sub TransposeWithRepeatingHeaders()

    With ThisWorkbook.Worksheets("Sheet2")

        Dim inputArray() As Variant
        inputArray = .Range("A1:C4").Value2

        Dim rowCountInOutput As Long
        ' Multiplied by two because each item will be preceded by a "header"
        rowCountInOutput = (UBound(inputArray, 1) - 1) * UBound(inputArray, 2) * 2

        Dim outputArray() As Variant
        ReDim outputArray(1 To rowCountInOutput, 1 To 1)

        Dim readRowIndex As Long
        Dim readColumnIndex As Long
        Dim writeIndex As Long

        For readRowIndex = (LBound(inputArray, 1) + 1) To UBound(inputArray, 1) ' Skip header on first row
            For readColumnIndex = LBound(inputArray, 2) To UBound(inputArray, 2)

                writeIndex = writeIndex + 1
                outputArray(writeIndex, 1) = inputArray(1, readColumnIndex) ' Assumes headers are on first row of inputArray

                writeIndex = writeIndex + 1
                outputArray(writeIndex, 1) = inputArray(readRowIndex, readColumnIndex)

            Next readColumnIndex
        Next readRowIndex

        .Range("E1").Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
    End With
End Sub

---

Редактировать: Если вам нужно работать с большими массивами / диапазонами, приведенный ниже код может быть лучшим подходом.В настоящее время в массиве с накоплением будет записано два столбца справа от исходных данных (измените это при необходимости).

Вы можете настроить константу MAXIMUM_CHUNK_SIZE (максимальное количество строк для обработки в любой момент времени) чтобы увидеть, что ваша машина может справиться.Я полагаю, что если он будет слишком маленьким, то выполнение кода займет больше времени, а если он станет слишком большим, у вас могут возникнуть проблемы с памятью.10000 может быть хорошей отправной точкой, я не знаю.

Option Explicit

Private Sub StackWithRepeatingHeaders()

    Const MAXIMUM_CHUNK_SIZE As Long = 10000 ' More specifically, the maximum number of rows to consume per iteration

    With ThisWorkbook.Worksheets("Sheet2")
        Dim inputRange As Range
        Set inputRange = .Range("A1:Z20000") ' Include headers please

        Dim columnHeaders As Variant
        columnHeaders = Application.Index(inputRange, 1, 0)

        Dim inputColumnCount As Long
        inputColumnCount = inputRange.Columns.Count

        ' Store only the "body", as "headers" are being stored in their own array
        Set inputRange = inputRange.Offset(1, 0).Resize(inputRange.Rows.Count - 1, inputColumnCount)

        Dim inputRowCount As Long
        inputRowCount = inputRange.Rows.Count

        Dim totalOutputRowCount As Long ' Multiplied by two because each item will be preceded by a "header"
        totalOutputRowCount = inputRowCount * inputColumnCount * 2

        If totalOutputRowCount > .Rows.Count Then
            MsgBox ("There are not enough rows in this sheet to stack this range (" & Format$(totalOutputRowCount, "#,###") & " rows required). Code will stop running now.")
            Exit Sub
        End If

        Dim firstOutputCell As Range ' Stack from this cell downward
        Set firstOutputCell = .Cells(1, inputRange.Columns(inputRange.Columns.Count).Column + 2) ' +2 could error if inputrange ends near last column of sheet
    End With

    Dim outputArray() As Variant
    ReDim outputArray(1 To (MAXIMUM_CHUNK_SIZE * inputColumnCount * 2), 1 To 1)

    Dim chunkStartIndex As Long
    For chunkStartIndex = 1 To inputRowCount

        Dim currentChunkSize As Long
        currentChunkSize = Application.Min(MAXIMUM_CHUNK_SIZE, inputRowCount - chunkStartIndex + 1)

        Dim inputArray() As Variant
        inputArray = inputRange.Offset(chunkStartIndex - 1, 0).Resize(currentChunkSize, inputColumnCount).Value2 ' -1 as 0-based

        If currentChunkSize <> MAXIMUM_CHUNK_SIZE Then
            ' Think this line will only run on the last iteration (when "remaining rows" might be < MAXIMUM_CHUNK_SIZE)
            ' Avoids needless Redims
            ReDim outputArray(1 To (currentChunkSize * inputColumnCount * 2), 1 To 1)
        End If

        Dim readRowIndex As Long
        Dim readColumnIndex As Long

        Dim arrayWriteIndex As Long
        arrayWriteIndex = 0

        For readRowIndex = 1 To currentChunkSize
            For readColumnIndex = 1 To inputColumnCount

                arrayWriteIndex = arrayWriteIndex + 1
                outputArray(arrayWriteIndex, 1) = columnHeaders(1, readColumnIndex)

                arrayWriteIndex = arrayWriteIndex + 1
                outputArray(arrayWriteIndex, 1) = inputArray(readRowIndex, readColumnIndex)

            Next readColumnIndex
        Next readRowIndex

        Dim sheetWriteIndex As Long
        firstOutputCell.Offset(sheetWriteIndex, 0).Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value2 = outputArray
        sheetWriteIndex = sheetWriteIndex + (currentChunkSize * inputColumnCount * 2)

        chunkStartIndex = chunkStartIndex + currentChunkSize - 1
    Next chunkStartIndex

End Sub

Answer 2

Вы можете попробовать это (замените «mySheetName» на ваше фактическое имя листа):

Sub TransposeAndDuplicateHeaders()
    Dim arr As Variant

    With Worksheets("mySheetName")
        arr = .UsedRange.Value
        .UsedRange.ClearContents

        Dim i As Long, j As Long
        For i = 2 To UBound(arr, 1)
            For j = 1 To UBound(arr, 2)
                .Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 1, 1).Value = arr(1, j)
                .Cells((i - 1) * UBound(arr, 2) + (j - 1) * 2 + 2, 1).Value = arr(i, j)
            Next
        Next
    End With
End Sub

Предупреждение : это очистит исходное содержимое листа «mySheetName», поэтому сделайтерезервная копия

Answer 3

Попробуйте адаптировать это к именам вашей таблицы:

Sub ReConfigure()
    Dim s1 As Worksheet, s2 As Worksheet, h1 As String, h2 As String, h3 As String
    Dim i As Long, j As Long, N As Long

    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    j = 1

    With s1
        h1 = .Range("A1")
        h2 = .Range("B1")
        h3 = .Range("C1")
        N = .Cells(Rows.Count, "A").End(xlUp).Row

        For i = 2 To N
            s2.Cells(j, 1) = h1
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 1).Value
            j = j + 1
            s2.Cells(j, 1) = h2
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 2).Value
            j = j + 1
            s2.Cells(j, 1).Value = h3
            j = j + 1
            s2.Cells(j, 1).Value = .Cells(i, 3).Value
            j = j + 1
        Next i
    End With
End Sub

Я использую Sheet1 для ввода и Sheet2 для вывода.