With Excel VBA Create Multiple Rows From One Row

Question

I have an Excel sheet (InData) which has individual rows of data by unique "ID NUMBER". Each ID Number may have multiple "deductions" and "benefits" contained in the one row. But I need to convert the single row of data into multiple rows by ID Number and write the results into a new sheet (OutData).

I tried to attach my sample Excel file but can't find way to do it. So attached sample images for InData and OutData.

This is InData...

This is OuData...

Below is code I'm using.

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

Does your code not work at all? Does it work, just not as you expect? Does it error somewhere (if so, where and what error)? — BruceWayne
– BruceWayne, Commented Mar 10, 2016 at 18:47
Bruce, the code works but it does not generate desired output as shown in OutData image. — user2397403
– user2397403, Commented Mar 10, 2016 at 20:06

Alexander Bell · Accepted Answer · 2016-03-10 18:54:57Z

0

Pertinent to your task definition, it seems that you can achieve the result simply by deletion of the unnecessary Worksheet Columns, which could be performed as, for example: Columns("H").Delete, or Columns(7).EntireColumn.Delete and so on (see the following sample VBA code snippet):

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

Then you can just re-arrange the order of residual data columns.

Hope this may help.

edited Mar 10, 2016 at 18:54

answered Mar 10, 2016 at 18:38

Alexander Bell

7,9163 gold badges29 silver badges44 bronze badges

Sign up to request clarification or add additional context in comments.

Collectives™ on Stack Overflow

With Excel VBA Create Multiple Rows From One Row

1 Answer 1

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related