Loop/copy rows variable times to new sheet

[Patti]

I have a sheet in which every row needs to be copied to a new sheet, but a
variable number of times. Example (source sheet):

Column A Column B
"Two" Pete
"Three" John
"Three" Cindy

I want to look at *text* in column A and say "if A1 is Two then copy this
row to DestinationSheet 2 times, if text is Three copy 3 times." There
will only be 2 or 3 different conditions. When the loop is complete,
DestinationSheet would look like:

Column A Column B
"Two" Pete
"Two" Pete
"Three" John
"Three" John
"Three" John
"Three" Cindy
"Three" Cindy
"Three" Cindy

What is the most efficient way to do this?

Thanks in advance!

Patti

 

[iainking]

I have a sheet in which every row needs to be copied to a new sheet, but a
variable number of times. Example (source sheet):

Column A Column B
"Two" Pete
"Three" John
"Three" Cindy

I want to look at *text* in column A and say "if A1 is Two then copy this
row to DestinationSheet 2 times, if text is Three copy 3 times." There
will only be 2 or 3 different conditions. When the loop is complete,
DestinationSheet would look like:

Column A Column B
"Two" Pete
"Two" Pete
"Three" John
"Three" John
"Three" John
"Three" Cindy
"Three" Cindy
"Three" Cindy

What is the most efficient way to do this?

Thanks in advance!

Patti

this should work:

dim fr as long, dr as long, numRows as long, i as long
dim from as string, dest as string

from="Sheet1" 'change these to whatever
dest="Sheet2"

fr=1
dr=0

with thisworkbook.sheets(from)
do
select case .cells(fr, 1).value 'column 1 = A
case "Two"
numRows=2
case "Three"
numRows=3
case else
numRows=1
end select
for i=1 to numRows
dr=dr+1
thisworkbook.sheets(dest).cells(dr, 1).value=.cells(fr,1).value
thisworkbook.sheets(dest).cells(dr, 2).value=.cells(fr,2).value
next
fr=fr+1
loop until .cells(fr, 1).value=""
end with


Iain

 

[Guest]

Try something like this. You will need to modify these two lines

Set wksCopyFrom = Sheets("Sheet1")
Set wksCopyTo = Sheets("Sheet2")

To be the sheet name you are copying from and the sheet name you are copying
to.

Sub test()
Call CopyTextMultipleTimes("Two", 2)
Call CopyTextMultipleTimes("Three", 3)

End Sub

Sub CopyTextMultipleTimes(ByVal TextToFind As String, ByVal Copies As Integer)
Dim wksCopyFrom As Worksheet
Dim wksCopyTo As Worksheet
Dim rngCopyFrom As Range
Dim rngToSearch As Range Set wksCopyFrom = Sheets("Sheet1")
Set wksCopyTo = Sheets("Sheet2")

Dim rngCopyTo As Range
Dim rngCurrent As Range
Dim rngFirst As Range
Dim intCounter As Integer

Set rngToSearch = wksCopyFrom.Columns(1)
Set rngCurrent = rngToSearch.Find(TextToFind)
If Not rngCurrent Is Nothing Then
Set rngFirst = rngCurrent
Set rngCopyFrom = rngCurrent.EntireRow
Do
Set rngCopyFrom = Union(rngCurrent.EntireRow, rngCopyFrom)
Set rngCurrent = rngToSearch.FindNext(rngCurrent)
Loop Until rngCurrent.Address = rngFirst.Address

For intCounter = 1 To Copies
Set rngCopyTo = wksCopyTo.Range("A65536").End(xlUp).Offset(1, 0)
rngCopyFrom.Copy rngCopyTo
Next intCounter
End If

End Sub

 

[Tom Ogilvy]

Dim rng as Range, cell as Range
Dim kk as Long, i as long
With Worksheets("sheet1")
set rng = .Range(.Cells(2,1),.Cells(2,1).End(xldown))
End with
kk = 2
for each cell in rng
num = 0
Select Case lcase(cell.value)
Case "two"
Num = 2
Case "three"
Num = 3
Case "four"
Num = 4
End Select

for i = 1 to Num
cell.EntireRow.copy Destination:=Worksheets("Sheet2") _
.Cells(kk,1)
kk = kk + 1
next
Next

 

[Guest]

Sorry one of the carriage returns seems to have been deleted when thiss was
posted... And just a note don't try to copy something less than 1 time (which
really only makes sense anyway)

Sub test()
Call CopyTextMultipleTimes("Two", 2)
Call CopyTextMultipleTimes("Three", 3)

End Sub

Sub CopyTextMultipleTimes(ByVal TextToFind As String, ByVal Copies As Integer)
Dim wksCopyFrom As Worksheet
Dim wksCopyTo As Worksheet
Dim rngCopyFrom As Range
Dim rngToSearch As Range

Set wksCopyFrom = Sheets("Sheet1")
Set wksCopyTo = Sheets("Sheet2")

Dim rngCopyTo As Range
Dim rngCurrent As Range
Dim rngFirst As Range
Dim intCounter As Integer

Set rngToSearch = wksCopyFrom.Columns(1)
Set rngCurrent = rngToSearch.Find(TextToFind)
If Not rngCurrent Is Nothing Then
Set rngFirst = rngCurrent
Set rngCopyFrom = rngCurrent.EntireRow
Do
Set rngCopyFrom = Union(rngCurrent.EntireRow, rngCopyFrom)
Set rngCurrent = rngToSearch.FindNext(rngCurrent)
Loop Until rngCurrent.Address = rngFirst.Address

For intCounter = 1 To Copies
Set rngCopyTo = wksCopyTo.Range("A65536").End(xlUp).Offset(1, 0)
rngCopyFrom.Copy rngCopyTo
Next intCounter
End If

End Sub

 

[Patti]

this should work:

dim fr as long, dr as long, numRows as long, i as long
dim from as string, dest as string

from="Sheet1" 'change these to whatever
dest="Sheet2"

fr=1
dr=0

with thisworkbook.sheets(from)
do
select case .cells(fr, 1).value 'column 1 = A
case "Two"
numRows=2
case "Three"
numRows=3
case else
numRows=1
end select
for i=1 to numRows
dr=dr+1
thisworkbook.sheets(dest).cells(dr, 1).value=.cells(fr,1).value
thisworkbook.sheets(dest).cells(dr, 2).value=.cells(fr,2).value
next
fr=fr+1
loop until .cells(fr, 1).value=""
end with


Iain

Iain,

Thanks, this does work beautifully for the example I have given. Since I
actually have many columns of data,I am wondering, though, if there is a way
to copy the whole row at once rather than:

thisworkbook.sheets(dest).cells(dr, 1).value=.cells(fr,1).value
thisworkbook.sheets(dest).cells(dr, 2).value=.cells(fr,2).value

Regards,

Patti

 

[Patti]

Exactly what I need, Tom. Thanks to all of you!

Patti

 

[iainking]

Iain,

Thanks, this does work beautifully for the example I have given. Since I
actually have many columns of data,I am wondering, though, if there is a way
to copy the whole row at once rather than:

thisworkbook.sheets(dest).cells(dr, 1).value=.cells(fr,1).value
thisworkbook.sheets(dest).cells(dr, 2).value=.cells(fr,2).value

Regards,

Patti

..cells(fr,1).entirerow.copy
..cells(dr,1).paste

though it might be better to use pastespecial, pasting only values

Iain

 

[iainking]

cells(fr,1).entirerow.copy

.cells(dr,1).paste

though it might be better to use pastespecial, pasting only values

Iain

Of course, line 2 should be:

thisworkbook.sheets(dest).cells(dr,1).paste

Iain