使用 Excel VBA 从一行创建多行答案

【问题标题】：With Excel VBA Create Multiple Rows From One Row使用 Excel VBA 从一行创建多行
【发布时间】：2016-03-10 18:32:48
【问题描述】：

我有一个 Excel 工作表 (InData)，其中包含由唯一“ID NUMBER”组成的单独数据行。每个身份证号码在一行中可能包含多个“扣除”和“利益”。但是我需要将单行数据通过 ID Number 转换成多行，并将结果写入新的工作表（OutData）中。

我试图附上我的示例 Excel 文件，但找不到方法。所以附上了 InData 和 OutData 的示例图片。

这是 InData...

这是OuData...

下面是我正在使用的代码。

Option Explicit
'Found original VBA here...
'http://stackoverflow.com/questions/3698442/convert-row-with-columns-of-data-into-column-with-multiple-rows-in-excel

Sub reOrgV2_New(inSource As Range, inTarget As Range)
'' This version works directly on the worksheet
'' and transfers the result directly to the target
'' given as the top-left cell of the result.

    Dim resNames()
    Dim propNum As Integer
    Dim srcRows As Integer
    Dim resRows As Integer
    Dim i As Integer
    Dim j As Integer
    Dim g As Integer

    '' Shape the result
    resNames = Array("Deduction Desc", "Deduction Amount", "Deduction Start Date", "Deduction Stop Date", _
    "Benefit Desc", "Benefit Amount", "Benefit Start Date", "Benefit Stop Date")
    propNum = 1 + UBound(resNames)

    '' Row counts
    srcRows = inSource.Rows.Count
    resRows = srcRows * propNum

    '' re-org and transfer source to result range
     inTarget = inTarget.Resize(resRows, 7)

    g = 1
    For i = 1 To srcRows
        For j = 0 To 7
            inTarget.Item(g + j, 1) = inSource.Item(i, 1)      '' ID NUMBER
            inTarget.Item(g + j, 2) = inSource.Item(i, 2)      '' LAST NAME
            inTarget.Item(g + j, 3) = inSource.Item(i, 3)      '' FIRST NAME
            inTarget.Item(g + j, 4) = resNames(j)              '' Column Type
            inTarget.Item(g + j, 5) = inSource.Item(i, j + 4)  '' Value
        Next j
        g = g + propNum
    Next i
End Sub
'' Call ReOrgV2_New with input and output ranges
Sub ReOrg_New()
    Dim ws As Worksheet
    Dim i As Integer
    i = Range("InData!A:A").Find("").Row - 2
    reOrgV2_New Range("InData!A2").Resize(i, 7), [OutData!A2]

    With Sheets("OutData")
        'We select the sheet so we can change the window view
        .Select

        '' apply column headings and autofit/align
        .Range("A1:E1").Value = Array("ID NUMBER", "LAST NAME", "FIRST NAME", "Column Type", "Value")
        .Columns("A:E").EntireColumn.AutoFit
        .Columns("E:E").HorizontalAlignment = xlRight

    End With

End Sub

【问题讨论】：

您的代码根本不起作用吗？它是否有效，只是不符合您的预期？它是否在某个地方出错（如果有，在哪里以及什么错误）？
布鲁斯，代码可以工作，但它没有生成所需的输出，如 OutData 图像所示。

标签： vba excel

【解决方案1】：

与您的任务定义相关，您似乎可以通过删除不必要的工作表列来实现结果，例如：Columns("H").Delete或Columns(7).EntireColumn.Delete等（见下文示例 VBA 代码 sn-p):

Sub DeleteColumns()

    'delete columns
    Columns("AR:AU").Delete
    Columns("H:AL").Delete

    ' re-arrange columns order
    Columns("D").Cut
    Columns("F").Insert Shift:=xlToRight
End Sub

然后你可以重新排列残差数据列的顺序。

希望这会有所帮助。

【讨论】：