使用Excel VBA从一行创建多行

我有一个Excel工作表（InData），它通过唯一的“ID号”包含单独的数据行。每个身份证号码可能在一行中包含多个“扣减”和“福利”。但是我需要按ID号将单行数据转换为多行，并将结果写入新的工作表（OutData）

我试图附加我的示例Excel文件，但找不到方法。因此，附上InData和OutData的示例图像

我是英达。。。

这是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

---

与任务定义相关，似乎只需删除不必要的工作表列即可获得结果，例如：

Columns（“H”）.Delete

，或

Columns（7）.entireclumn.Delete

等（请参见以下示例VBA代码片段）：

然后您可以重新排列剩余数据列的顺序

---

希望这能有所帮助。

您的代码根本不起作用吗？它能工作吗，只是不像你期望的那样？它是否在某个地方出错（如果是，在哪里，什么错误）？Bruce，代码可以工作，但它没有生成所需的输出，如OutData图像所示。

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