Need to transpose the vertical data to horizontal format, but few cells in Vertical format can have more than 2 or 3 sub categories in Excel VBA

问题

This is BEFORE image This is AFTER Image

回答1:

It is based on the assumption that your original data is still listed in the column direction.

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

Sheet1

Sheet2

回答2:

I think I owe you this for the blunder :) Since you need dynamic range, included inputboxes to select range titleRange = C4:D6 and 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

Image of Sheet1

Image of New Sheet

来源：https://stackoverflow.com/questions/60574653/need-to-transpose-the-vertical-data-to-horizontal-format-but-few-cells-in-verti