按数量复制行

时间:2019-04-08 19:09:00

标签: excel vba

我想按列中标识的数量复制行。我对此有问题

到目前为止,我已经能够按数量复制行,但是无法添加该行用于哪个“块”

这是数据: enter image description here

预期结果: enter image description here

这是我正在使用的代码。这是另一个代码的调整版本

Sub CopyBlocks()     昏暗的StartRow,LastRow,NewSheetRow     昏暗,我为整数

Worksheets("test").Activate
LastRow = Cells(Rows.Count, 7).Row
NewSheetRow = 10

For StartRow = 10 To LastRow
n = CInt(Worksheets("test").Range("AA" & StartRow).Value)
For i = 1 To n
    Worksheets("test2").Range("C" & NewSheetRow).Value = Worksheets("test").Range("g" & StartRow).Value
    Worksheets("test2").Range("D" & NewSheetRow).Value = Worksheets("test").Range("H" & StartRow).Value
    Worksheets("test2").Range("E" & NewSheetRow).Value = Worksheets("test").Range("I" & StartRow).Value
    Worksheets("test2").Range("F" & NewSheetRow).Value = Worksheets("test").Range("J" & StartRow).Value
    Worksheets("test2").Range("G" & NewSheetRow).Value = Worksheets("test").Range("K" & StartRow).Value

    NewSheetRow = NewSheetRow + 1
Next i
Next StartRow

结束子

1 个答案:

答案 0 :(得分:0)

如果您使用的是excel 2016,则可以使用PowerQuery很好地取消透视此数据集。 Keith在评论中为您提供了一个非常有用的链接。过滤掉零,您几乎可以解决问题。这些重复行的可能性使游戏变得有些复杂。如果您只想了解M语言的精髓,可以使用List.Numbers函数到达那里。

但是,在VBA中破解它也不难。我建议采取另一种不同的策略,即仅在交叉表的范围内进行迭代,当计数超过0时拔出行标题和列标题。

Sub foo()

    Dim outputRow As Integer

    'start your output at whatever row is best
    outputRow = 1

    'set your range to cover the counts in your crosstab
    For Each c In Range("A1:Z99")
        If c.Value > 0 Then

            For i = 1 To c.Value

                    'write the values off the current row headers over to comparable positions in your output row
                    Worksheets("test2").Cells(outputRow, 3).Value = Cells(c.Row, 1).Value
                    Worksheets("test2").Cells(outputRow, 4).Value = Cells(c.Row, 2).Value
                    .
                    .
                    .

                    'write the values off the current column headers into output row
                    Worksheets("test2").Cells(outputRow, 8).Value = Cells(1, c.Column).Value

                outputRow = outputRow + 1
            Next i

        End If
    Next c
End Sub

祝你好运,希望对你有帮助