Развернуть строки на основе столбца

Question

Я создаю иерархии, и мне нужно набросать их в формате справа. Было бы намного проще, если бы я мог просто наметить иерархию в одном столбце и автоматически развернуть ее (слева -> справа в образце). Несколько соображений:

1. В первом столбце началом новой иерархии всегда будет значение 'A'
2. Иерархии могут иметь длину от 2 до 10 дочерних элементов * 1006. *

Есть мысли?

Answer 1

Введите буквы только в столбце A, начинайте каждую новую последовательность со слова HEADER. Затем запустите макрос и расширения должны быть созданы.

Sub expand()

    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim cell As Range, cellHeader As Range
    Dim irow As Integer, i As Integer
    Dim iCount As Integer, iLast As Long

    ' find last row in col A
    iLast = ws.Range("A" & Rows.Count).End(xlUp).Row

    'scan down the sheet
    For Each cell In ws.Range("A1:A" & iLast)

        If UCase(cell) = "DIRECT" Then

            ' remember the header line
            Set cellHeader = cell
            With cellHeader
                .BorderAround xlContinuous
                .Font.Bold = True
            End With

        ElseIf Len(cell) > 0 Then

            cell.BorderAround xlContinuous

            ' start of sequence
            If cell = "A" Then
                irow = 1
                iCount = 0
            End If

            ' add header value
            With cellHeader.Offset(0, irow)
                .Value = "L" & irow
                .Font.Bold = True
                .BorderAround xlContinuous
            End With

            ' copy cell diagonally upwards
            If irow > 1 Then
                For i = 1 To irow - 1
                    cell.Offset(-i, i) = cell.Value
                    cell.Offset(-i, i).BorderAround xlContinuous
                Next
            End If

            ' check max children
            iCount = iCount + 1
            If iCount > 10 Then
                MsgBox "Children count > 10", vbCritical, "Error"
                Exit Sub
            End If
            irow = irow + 1
        End If
    Next
    MsgBox "Expansion Complete", vbInformation
End Sub

Answer 2

Вы не отвечаете на мои вопросы, и я больше не могу ждать ...

Пожалуйста, проверьте следующий код, который работает на основе ваших предположений: ваши обсуждаемые иерархии все время имеют своего рода заголовок (Direct в столбце A: A и L1 в B: B). Это или пустая строка устанавливает нижнюю часть иерархии.

Вот код:

Sub HierarchyArrangeMultipleR()
  Dim sh As Worksheet, i As Long, j As Long, lastR As Long, lastH As Long
  Dim arrI As Variant, arrTr As Variant, colN As Long, k As Long, h As Long

  Set sh = ActiveSheet 'please, use here your worksheet
  lastR = sh.Range("A" & sh.Rows.count).End(xlUp).Row

  For k = 1 To lastR
    If lastH > 0 Then k = lastH + 1
    If k >= lastR Then Exit For
Start:
    If sh.Range("A" & k).Value = "Direct" And sh.Range("B" & k).Value = "L1" Then
        For i = 1 To 10
            If sh.Range("A" & k + i).Value = "Direct" Or _
                  sh.Range("A" & k + i).Value = Empty Then
                lastH = k + i - 1: Exit For
            End If
        Next i
        For h = 3 To lastH - k
            sh.Cells(k, h) = "L" & h - 1
        Next h
    Else
        k = k + 1: GoTo Start
    End If
      arrI = sh.Range("A" & k + 1 & ":A" & lastH).Value
      ReDim arrTr(1 To UBound(arrI) - 1)
      colN = 1
      For i = k To lastH - 2
        For j = 1 To UBound(arrTr) 'lastH - i + k - 2
            arrTr(j) = arrI(j, 1)
        Next j

        colN = colN + 1
        sh.Range(sh.Cells(k + 1, colN), sh.Cells(lastH + 1 - colN, colN)).Value = WorksheetFunction.Transpose(arrTr)
      Next i
      Erase arrTr
  Next k
End Sub