Question

我有一张Excel工作表（InData），其中包含唯一的＆＃34; ID NUMBER＆＃34;的单独数据行。每个ID号码可能有多个＆＃34;扣除＆＃34;和＆＃34;福利＆＃34;包含在一行中。但我需要通过ID号将单行数据转换为多行，并将结果写入新表（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

Answer 1

与您的任务定义相关，您似乎只需删除不必要的工作表列即可实现结果，这些列可以执行，例如：Columns("H").Delete或Columns(7).EntireColumn.Delete等等（请参阅以下示例VBA代码段）：

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

然后您可以重新排列残留数据列的顺序。

希望这可能会有所帮助。

使用Excel VBA从一行创建多行

1 个答案: