Question

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

通过使用＃34; Q＆＃34;中的countif公式，我已经获得了大于0的列的总计数行数。为了这个vba。

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

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

2 个答案: