Необходимо переместить вертикальные данные в горизонтальный формат, но немногие ячейки в вертикальном формате могут иметь более 2 или 3 подкатегорий в Excel VBA.

Question

Это ДО изображения Это ПОСЛЕ изображения

Answer 1

Это основано на предположении, что ваши исходные данные все еще перечислены в направлении столбца.

Sub test2()
    Dim Ws As Worksheet
    Dim toWs As Worksheet
    Dim vDB, vR()
    Dim rngDB As Range
    Dim i As Long, j As Long, n As Long
    Dim r As Long, c As Long, k As Long

    Set Ws = Sheets(1)
    Set toWs = Sheets(2)

    Set rngDB = Ws.Range("a1").CurrentRegion
    vDB = rngDB

    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For j = 2 To c
        n = n + 1
        'ReDim Preserve vR(1 To 4, 1 To n)
        ReDim Preserve vR(1 To 5, 1 To n)
        vR(1, n) = vDB(1, j)
        vR(2, n) = vDB(2, j)
        vR(3, n) = vDB(3, j)
        vR(4, n) = vDB(4, j)
        vR(5, n) = vDB(r, j) 'added insurance
        'For i = 5 To r
        For i = 5 To r - 1
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                vR(4, n) = vDB(i, j)
            End If
        Next i
    Next j

    With toWs
        k = .UsedRange.Rows.Count + 1
        '.Range("a" & k).Resize(n, 4) = WorksheetFunction.Transpose(vR)
        .Range("a" & k).Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With

End Sub

Лист1

Лист2

Answer 2

Я думаю, что я должен вам это за грубую ошибку :) Так как вам нужен динамический диапазон c, включены поля ввода для выбора диапазона titleRange = C4: D6 и dataRange = C7: D10

Sub test()
ThisWorkbook.Activate
On Error Resume Next

Dim wS1 As Worksheet
Dim wS2 As Worksheet
Dim titleRange, dataRange, targetCell As Range

Set wS1 = Sheets("Sheet1")
Set wS2 = Worksheets.Add
Set targetCell = wS2.Range("B2")

wS1.Activate

Set titleRange = Application.InputBox(prompt:="Sample", Type:=8)
    If titleRange Is Nothing Then
    MsgBox "You didn't select titleRange"
    Exit Sub
    End If
Set dataRange = Application.InputBox(prompt:="Sample", Type:=8)
    If dataRange Is Nothing Then
    MsgBox "You didn't select dataRange"
    Exit Sub
    End If

For i = 1 To titleRange.Columns.Count

    titleRange.Columns(i).Copy
    targetCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False

    dataRange.Columns(i).Copy
    wS2.Range("E" & targetCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False

    Set targetCell = wS2.Range("B" & wS2.Range("E" & Rows.Count).End(xlUp).Row + 1)

Next
End Sub

Изображение листа 1

Изображение нового листа