VBA Help - Create a Duplicate row based on Cell Value - Excel 2016

[Johnny Thunder]

Hello All,

I have a report that has data in a Column based format (Left to right) that I need to convert into a linear format (up and down) and not sure that fastest way to accomplish this.

My data has column detail from Columns A:F, in in Columns G:AP there are ID's that I need to grab and create a duplicate of the row and enter each unique ID into column F. I did create a helper column in Column E that Counts how many values are in Columns G:AP.

Once the code runs it will clear all the values in columns G:AP since they have now been moved into Column F as unique rows.

Currently my report has 121 rows of data and for each row so will definitely need code to achieve this quickly.

Here is a mocked-up example of what I mean;

Current (I intentionally left columns B:E out of the grid for this example)
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Col A[/TD]
[TD]Col E[/TD]
[TD]Col F[/TD]
[TD]ID1[/TD]
[TD]ID2[/TD]
[TD]ID3[/TD]
[TD]ID4[/TD]
[/TR]
[TR]
[TD]Name1[/TD]
[TD]3[/TD]
[TD]Currently Blank[/TD]
[TD]J1[/TD]
[TD]J2[/TD]
[TD]J3[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name2[/TD]
[TD]2[/TD]
[TD]Currently Blank[/TD]
[TD]Z5[/TD]
[TD]Z10[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]






Expectation
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Col A[/TD]
[TD]Col E[/TD]
[TD]Col F[/TD]
[TD]ID1[/TD]
[TD]ID2[/TD]
[TD]ID3[/TD]
[TD]ID4[/TD]
[/TR]
[TR]
[TD]Name 1[/TD]
[TD]3[/TD]
[TD]J1[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 1[/TD]
[TD]3[/TD]
[TD]J2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 1[/TD]
[TD]3[/TD]
[TD]J3[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 2[/TD]
[TD]2[/TD]
[TD]Z5[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name 2[/TD]
[TD]2[/TD]
[TD]Z10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]











Any help on this is appreciated.

 

[JLGWhiz]

Try this

Sub t()
Dim i As Long, cnt As Long, rng As Range
With ActiveSheet
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
        cnt = .Cells(i, 5).Value
        Set rng = .Cells(i, 7).Resize(, cnt)
        .Cells(i + 1, 1).Resize(cnt - 1).EntireRow.Insert
        .Cells(i, 1).Resize(cnt) = .Cells(i, 1).Value
        rng.Copy
        .Cells(i, 6).PasteSpecial xlPasteValues, Transpose:=True
        rng.ClearContents
    Next
End With
End Sub

 

[Johnny Thunder]

Code seems to work ok but I am having an issue since the code is defining Column(1) as the column to define how many rows to work with, my column(1) has several blanks in it. How would I modify to use column E as the column to define row count?

 

[JLGWhiz]

Sub t2()
Dim i As Long, cnt As Long, rng As Range
With ActiveSheet
    For i = .Cells(Rows.Count, 5).End(xlUp).Row To 2 Step -1
        cnt = .Cells(i, 5).Value
        Set rng = .Cells(i, 7).Resize(, cnt)
        .Cells(i + 1, 1).Resize(cnt - 1).EntireRow.Insert
        If .Cells(i, 1) <> "" Then
            .Cells(i, 1).Resize(cnt) = .Cells(i, 1).Value
        End If
        rng.Copy
        .Cells(i, 6).PasteSpecial xlPasteValues, Transpose:=True
        rng.ClearContents
    Next
End With
End Sub

 

[Johnny Thunder]

That worked great! Thanks for all the help on this.

 

[JLGWhiz]

That worked great! Thanks for all the help on this.

You're welcome,
Regards, JLG