插入行并将数据从水平布局移动/拉到垂直布局

Question

我有一个数据表，这样信息的特定列需要从水平布局转换并插入到初始行下面。为了使事情变得更复杂，需要忽略任何值为零的列，并且每行可能具有不同的列，其中零。

通过在此“v”列中使用“Q”列中的countif公式，我已经获得了为列总数计数大于0的行。

Sub H2V()
' H2V Macro
' Integrate vertical UB-04 codes
    Worksheets("Sheet1 (2)").Activate

    Dim r, count As Range
    Dim LastRow As Long
    Dim temp As Integer

    Set r = Range("A:P")
    Set count = Range("Q:Q")
    LastRow = Range("B" & Rows.count).End(xlUp).Row

    For n = LastRow To 1 Step -1
        temp = Range("Q" & n)

        If (temp > 1) Then
            Rows(n + 1 & ":" & n + temp).Insert Shift:=xlDown
        End If

    Next n

End Sub

但我不能为我的生活弄清楚如何将数据从水平集拉入新创建的行，使其垂直整合。

修订示例（更完整）：

Answer 1

你可以试试这个

Option Explicit

Sub main()
    Dim headers As Variant, names As Variant, data As Variant
    Dim iRow As Long

    With Worksheets("Sheet1 (2)")
        With .Range("A1").CurrentRegion
            headers = Application.Transpose(Application.Transpose(.Offset(, 1).Resize(1, .Columns.Count - 1).Value))
            names = Application.Transpose(.Offset(1).Resize(.Rows.Count - 1, 1).Value)
            data = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Value
            .ClearContents
            .Resize(1, 3).Value = Array("Name", "Object", "Value")
        End With

        For iRow = 1 To UBound(data)
            With .Cells(.Rows.Count, "B").End(xlUp)
                .Offset(1, -1).Value = names(iRow)
                .Offset(2, 0).Resize(UBound(headers)).Value = Application.Transpose(headers)
                .Offset(2, 1).Resize(UBound(data)).Value = Application.Transpose(Application.index(data, iRow, 0))
            End With
        Next

        With .Range("B3", Cells(.Rows.Count, "B").End(xlUp)).SpecialCells(xlCellTypeConstants)
            .Offset(, 1).Replace what:="0", replacement:="", lookat:=xlWhole
            .Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End With
    End With
End Sub

Answer 2

这不是最快的解决方案，明天会对此代码进行重做，但它确实有效，data_sht是您的示例数据所在的位置，而output_sht是Excel将修改后的数据放置的位置。

Sub data()

Dim data_sht As Worksheet
Dim output_sht As Worksheet
Dim cell As Range

Set data_sht = ThisWorkbook.Sheets("Sheet1")
Set output_sht = ThisWorkbook.Sheets("Sheet2")

Dim rng As Range
Set rng = data_sht.Range("A1").CurrentRegion

For Each cell In rng.Offset(1, 0)

Header = rng.Cells(1, 1)

If IsNumeric(cell) And cell.Value > 0 Then
    Object = rng.Cells(1, cell.Column)

With output_sht

    If .Columns("B:B").Cells.Count < 1 Then
        lastrow = 2
    Else
        lastrow = Range("B" & Rows.Count).End(xlUp).Row
    End If

    .Cells(1, 1) = Header
    .Cells(1, 2) = "Object"
    .Cells(1, 3) = "Value"
    .Cells(lastrow + 1, 1) = rng.Cells(cell.Row, 1)
    .Cells(lastrow + 2, 2) = Object
    .Cells(lastrow + 2, 3) = cell.Value
End With

End If

Next cell

With output_sht
    .Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3), _
    Header:=xlNo
End With

End Sub