需要将垂直数据转为水平格式，但很少有垂直格式的单元格可以在 Excel VBA 中有超过 2 个或 3 个子类别

Question

This is BEFORE image This is AFTER Image

Answer 1

我想我欠你这个错误:) 由于您需要动态范围，因此将输入框包含在 select 范围内 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

Sheet1

的图像

新图片Sheet

Answer 2

这是基于假设你的原始数据仍然列在列方向。

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

需要将垂直数据转为水平格式，但很少有垂直格式的单元格可以在 Excel VBA 中有超过 2 个或 3 个子类别

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

excel

vba

transpose

excel-formula

工作表 1

工作表 2