Duplicating lines by using a value in a cell

[adammon]

Is there a way to duplicate a line based on a value in one of the cells? For example: in columns A through C I have the data that I'd like to duplicate, and in column D I have the number for how many times I'd like to duplicate it. Below is an image of my beginning data.

And here is what I'm trying to achieve..

To complicate things a bit more, would there be a way to account for the original line as one of the duplicates? So if it's showing 2 in column D, there should only be 2 total lines for that given line.

This will be part of a macro, so I can always use the VBA coding that I can plug into it.

Links to images above..

Example 1
https://www.flickr.com/gp/161445705@N05/PpBt9v

Example 2
https://www.flickr.com/gp/161445705@N05/5p4sLg

 

[JoeMo]

This assumes the header "Description" is in cell A1 and the there are no empty rows within the data.

Sub MakeMore()
'assumes first header is in A1, no blank rows, col E is blank
Dim R As Range, i As Long
Set R = Range("A1").CurrentRegion
Application.ScreenUpdating = False
For i = R.Rows.Count To 2 Step -1
    With R.Rows(i)
        .Offset(1, 0).Resize(R.Columns(4).Cells(i).Value - 1).Insert shift:=xlDown
        .Resize(R.Columns(4).Cells(i).Value).FillDown
    End With
Next i
Application.ScreenUpdating = True
End Sub

 

[adammon]

Thanks for the help, Joe. That worked great, however, I'm having some trouble with the code I put in before the code you provided me. I put the code in below to remove the blank lines, before running your code, but it seems like the Text formatting part of the code doesn't allow the rest of my code to delete the blanks (thus, not allowing your code to work because blanks are still present).

Is there something that I can add to my code so the second part keeps the text formatting? Without the formatting it changes my cell values with zeros in front of them to just whole numbers (example: 00001 becomes 1).



Sub Macro1()
Columns("B:B").Select
Selection.NumberFormat = "@"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
On Error Resume Next
With Range("A1:F1500")
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub

 

[JoeMo]

What is a "blank line"? Do you mean an empty row within the data you want to process? Can you post some sample data having "blank lines" and the result you want for that data?

 

[adammon]

By "blank lines" I meant empty rows. The data that I'm using your code with is originally linked to data from another sheet using some IF and VLOOKUP formulas. So the first part of my macro is copying and pasting the values of my data. Then, I have the macro deleting the empty rows because my formulas go down to row 1,500 to allow any amount of data to be linked to this sheet (or at least 1,500 rows worth).
If I don't delete the empty rows, the Makemore code won't work. But if I change the format to text, the Macro1 code that I made, won't actually delete the rows.

	A	B	C	D	E	F
1	PO	Style	Description	Color Code	Size	Label Count
2	2003687	00001	GAIN FEDORA	NATUR	XS	2
3	2003687	00001	GAIN FEDORA	NATUR	S	4
4	2003687	00001	GAIN FEDORA	NATUR	M	6
5	2003687	00001	GAIN FEDORA	NATUR	L	5
6	2003687	00001	GAIN FEDORA	NATUR	XL	3

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>

Sheet1​

Worksheet Formulas Cell Formula A2 =IF('Data Entry'!A2="","",'Data Entry'!A2) B2 =IF('Data Entry'!B2="","",'Data Entry'!B2) C2 =IFERROR(VLOOKUP('Data Entry'!G2,'Style Master Reference'!D:F,3,FALSE),"") D2 =IF('Data Entry'!C2="","",'Data Entry'!C2) E2 =IF('Data Entry'!D2="","",'Data Entry'!D2) F2 =IF('Data Entry'!K2="","",'Data Entry'!K2) A3 =IF('Data Entry'!A3="","",'Data Entry'!A3) B3 =IF('Data Entry'!B3="","",'Data Entry'!B3) C3 =IFERROR(VLOOKUP('Data Entry'!G3,'Style Master Reference'!D:F,3,FALSE),"") D3 =IF('Data Entry'!C3="","",'Data Entry'!C3) E3 =IF('Data Entry'!D3="","",'Data Entry'!D3) F3 =IF('Data Entry'!K3="","",'Data Entry'!K3) A4 =IF('Data Entry'!A4="","",'Data Entry'!A4) B4 =IF('Data Entry'!B4="","",'Data Entry'!B4) C4 =IFERROR(VLOOKUP('Data Entry'!G4,'Style Master Reference'!D:F,3,FALSE),"") D4 =IF('Data Entry'!C4="","",'Data Entry'!C4) E4 =IF('Data Entry'!D4="","",'Data Entry'!D4) F4 =IF('Data Entry'!K4="","",'Data Entry'!K4) A5 =IF('Data Entry'!A5="","",'Data Entry'!A5) B5 =IF('Data Entry'!B5="","",'Data Entry'!B5) C5 =IFERROR(VLOOKUP('Data Entry'!G5,'Style Master Reference'!D:F,3,FALSE),"") D5 =IF('Data Entry'!C5="","",'Data Entry'!C5) E5 =IF('Data Entry'!D5="","",'Data Entry'!D5) F5 =IF('Data Entry'!K5="","",'Data Entry'!K5) A6 =IF('Data Entry'!A6="","",'Data Entry'!A6) B6 =IF('Data Entry'!B6="","",'Data Entry'!B6) C6 =IFERROR(VLOOKUP('Data Entry'!G6,'Style Master Reference'!D:F,3,FALSE),"") D6 =IF('Data Entry'!C6="","",'Data Entry'!C6) E6 =IF('Data Entry'!D6="","",'Data Entry'!D6) F6 =IF('Data Entry'!K6="","",'Data Entry'!K6) <thead> </thead><tbody> </tbody>

<tbody>
</tbody>

 

[adammon]

Here's all of the code I have if that helps too. It's broken into 4 different sections..

Sub Macro1()    Columns("B:B").Select
    Selection.NumberFormat = "@"
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   On Error Resume Next
With Range("A1:F1500")
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub


Sub Removezeros()
    Dim xRg As Range
    Dim xCell As Range
    Dim i As Long
    Dim J As Long
    Dim K As Long
    i = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("F1:F" & i)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "0" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "0" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub


Sub Removesingles()
    Dim xRg As Range
    Dim xCell As Range
    Dim i As Long
    Dim J As Long
    Dim K As Long
    i = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet3").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("F1:F" & i)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "1" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "1" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub


Sub MakeMore()
Dim R As Range, i As Long
Set R = Range("A1").CurrentRegion
Application.ScreenUpdating = False
For i = R.Rows.Count To 2 Step -1
    With R.Rows(i)
        .Offset(1, 0).Resize(R.Columns(6).Cells(i).Value - 1).Insert shift:=xlDown
        .Resize(R.Columns(6).Cells(i).Value).FillDown
    End With
Next i
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

I see at least a few issues with your code.

First, Copy/Paste values in formula cells that are returning "" can yield unexpected results with specialcells(xlblanks). I would not trust the specialcells method to isolate these cells. To see this try the following on a new sheet:

In A1 enter: =IF(B1="","",B1)
Leave B1 blank
in C1 enter: =ISBLANK(A1)
C1 will return FALSE as it should since A1 is not empty - there's a formula in the cell.
Now Copy/Paste Values in A1 and note there's nothing in the formula bar when A1 is the active cell, but note also that C1 still returns FALSE.
Now with A1 active press the Delete key and note that only now does C1 return TRUE. The same result obtains when using specialcells(xlblanks) after your copy/paste values. Instead of copy/paste values/specialcells you could test the cells in col B like this:

Dim c as range
For each c in Intersect(Columns("B"),Activesheet.UsedRange)
     If c.HasFormula and c.Value = "" Then c.Value = "#N/A"
Next c
with Intersect(Columns("B"),Activesheet.UsedRange)
    On Error Resume Next
   .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete
   On Error GoTo 0
End With

Second, when deleting entire rows as in your Removezeros and Removesingles macros, start at the bottom of the range and work up to the top so you don't have to adjust J and K after each deletion.