Duplicating lines by using a value in a cell

adammon

New Member
Joined
Apr 8, 2015
Messages
14
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.

74gE83


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

6L1z51


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
 
Last edited by a moderator:

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
This assumes the header "Description" is in cell A1 and the there are no empty rows within the data.
Code:
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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.

ABCDEF
POStyleDescriptionColor CodeSizeLabel Count
GAIN FEDORANATURXS
GAIN FEDORANATURS
GAIN FEDORANATURM
GAIN FEDORANATURL
GAIN FEDORANATURXL

<colgroup><col style="width: 25pxpx"><col><col><col><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]

[TD="align: center"]2[/TD]
[TD="align: right"]2003687[/TD]
[TD="align: right"]00001[/TD]

[TD="align: right"]2[/TD]

[TD="align: center"]3[/TD]
[TD="align: right"]2003687[/TD]
[TD="align: right"]00001[/TD]

[TD="align: right"]4[/TD]

[TD="align: center"]4[/TD]
[TD="align: right"]2003687[/TD]
[TD="align: right"]00001[/TD]

[TD="align: right"]6[/TD]

[TD="align: center"]5[/TD]
[TD="align: right"]2003687[/TD]
[TD="align: right"]00001[/TD]

[TD="align: right"]5[/TD]

[TD="align: center"]6[/TD]
[TD="align: right"]2003687[/TD]
[TD="align: right"]00001[/TD]

[TD="align: right"]3[/TD]

</tbody>
Sheet1

[TABLE="width: 85%"]
<tbody>[TR]
[TD]Worksheet Formulas[TABLE="width: 100%"]
<thead>[TR="bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]
[TH="width: 10px"]Cell[/TH]
[TH="align: left"]Formula[/TH]
[/TR]
</thead><tbody>[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]A2[/TH]
[TD="align: left"]=IF('Data Entry'!A2="","",'Data Entry'!A2)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]B2[/TH]
[TD="align: left"]=IF('Data Entry'!B2="","",'Data Entry'!B2)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]C2[/TH]
[TD="align: left"]=IFERROR(VLOOKUP('Data Entry'!G2,'Style Master Reference'!D:F,3,FALSE),"")[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]D2[/TH]
[TD="align: left"]=IF('Data Entry'!C2="","",'Data Entry'!C2)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]E2[/TH]
[TD="align: left"]=IF('Data Entry'!D2="","",'Data Entry'!D2)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]F2[/TH]
[TD="align: left"]=IF('Data Entry'!K2="","",'Data Entry'!K2)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]A3[/TH]
[TD="align: left"]=IF('Data Entry'!A3="","",'Data Entry'!A3)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]B3[/TH]
[TD="align: left"]=IF('Data Entry'!B3="","",'Data Entry'!B3)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]C3[/TH]
[TD="align: left"]=IFERROR(VLOOKUP('Data Entry'!G3,'Style Master Reference'!D:F,3,FALSE),"")[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]D3[/TH]
[TD="align: left"]=IF('Data Entry'!C3="","",'Data Entry'!C3)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]E3[/TH]
[TD="align: left"]=IF('Data Entry'!D3="","",'Data Entry'!D3)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]F3[/TH]
[TD="align: left"]=IF('Data Entry'!K3="","",'Data Entry'!K3)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]A4[/TH]
[TD="align: left"]=IF('Data Entry'!A4="","",'Data Entry'!A4)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]B4[/TH]
[TD="align: left"]=IF('Data Entry'!B4="","",'Data Entry'!B4)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]C4[/TH]
[TD="align: left"]=IFERROR(VLOOKUP('Data Entry'!G4,'Style Master Reference'!D:F,3,FALSE),"")[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]D4[/TH]
[TD="align: left"]=IF('Data Entry'!C4="","",'Data Entry'!C4)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]E4[/TH]
[TD="align: left"]=IF('Data Entry'!D4="","",'Data Entry'!D4)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]F4[/TH]
[TD="align: left"]=IF('Data Entry'!K4="","",'Data Entry'!K4)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]A5[/TH]
[TD="align: left"]=IF('Data Entry'!A5="","",'Data Entry'!A5)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]B5[/TH]
[TD="align: left"]=IF('Data Entry'!B5="","",'Data Entry'!B5)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]C5[/TH]
[TD="align: left"]=IFERROR(VLOOKUP('Data Entry'!G5,'Style Master Reference'!D:F,3,FALSE),"")[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]D5[/TH]
[TD="align: left"]=IF('Data Entry'!C5="","",'Data Entry'!C5)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]E5[/TH]
[TD="align: left"]=IF('Data Entry'!D5="","",'Data Entry'!D5)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]F5[/TH]
[TD="align: left"]=IF('Data Entry'!K5="","",'Data Entry'!K5)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]A6[/TH]
[TD="align: left"]=IF('Data Entry'!A6="","",'Data Entry'!A6)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]B6[/TH]
[TD="align: left"]=IF('Data Entry'!B6="","",'Data Entry'!B6)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]C6[/TH]
[TD="align: left"]=IFERROR(VLOOKUP('Data Entry'!G6,'Style Master Reference'!D:F,3,FALSE),"")[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]D6[/TH]
[TD="align: left"]=IF('Data Entry'!C6="","",'Data Entry'!C6)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]E6[/TH]
[TD="align: left"]=IF('Data Entry'!D6="","",'Data Entry'!D6)[/TD]
[/TR]
[TR]
[TH="width: 10px, bgcolor: [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=DAE7F5]#DAE7F5[/URL] "]F6[/TH]
[TD="align: left"]=IF('Data Entry'!K6="","",'Data Entry'!K6)[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Here's all of the code I have if that helps too. It's broken into 4 different sections..

Code:
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
 
Upvote 0
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:
Code:
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.
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,327
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top