If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Hi Stratis,

Try something like:

'=============
Public Sub Tester001()
Dim rng As Range
Dim i As Long, j As Long

Set rng = Selection '<<==== CHANGE

If rng.Columns.Count 1 Then
Set rng = rng.Resize(, 1)
End If

For i = rng.Rows.Count To 1 Step -1
With rng(i)
If Not IsNumeric(.Offset(0, 1).Value) _
Or .Offset(0, 1).Value < 1 Then
.Resize(1, 2).Delete shift:=xlUp
Else
j = .Offset(0, 1).Value
.Offset(1).Resize(j - 1, 2).Insert shift:=xlDown
.Resize(1, 2).Copy Destination:=.Resize(j)
End If
End With
Next i

End Sub
'<<=============


---
Regards,
Norman


"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Norman,
If we have a condition of j=1 then the code will error. I
note you test for j < 1 (and delete?) but not for 1. Either 0 (blank) or 1
could be interpretted as leaving the entry "as-is" bot not being mind readers
....!


"Norman Jones" wrote:

Hi Stratis,

Try something like:

'=============
Public Sub Tester001()
Dim rng As Range
Dim i As Long, j As Long

Set rng = Selection '<<==== CHANGE

If rng.Columns.Count 1 Then
Set rng = rng.Resize(, 1)
End If

For i = rng.Rows.Count To 1 Step -1
With rng(i)
If Not IsNumeric(.Offset(0, 1).Value) _
Or .Offset(0, 1).Value < 1 Then
.Resize(1, 2).Delete shift:=xlUp
Else
j = .Offset(0, 1).Value
.Offset(1).Resize(j - 1, 2).Insert shift:=xlDown
.Resize(1, 2).Copy Destination:=.Resize(j)
End If
End With
Next i

End Sub
'<<=============


---
Regards,
Norman


"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Stratis, You can try this. It worked in my test sample. It will put the
copies in column C and assumes your Original is in Columns A:B. It also
assumes the data starts in row 1 (no header). You can adjust the code
accordingly and delete columns A:B when done if you wish, or leave them
intact.

Sub CopyTimes()
Dim LRow As Long
Dim c As Range, SourceRng As Range, DestRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range("C" & CopyFrom & ":C" & CopyTo)
DestRng = c.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Hi Toppers,

If we have a condition of j=1 then the code will error

You are correct. In my initial code, I used the a condition If j 1.I then
amended the code to allow for alpha and negative values and lost the initial
condition in the process!

Either 0 (blank) or 1 could be interpretted as leaving the entry "as-is"
bot not being mind readers ...!

Indeed it could - I was simply too lazy to add an appropriate comment line.
The suggested code also elides the potential problem of positive non-integer
values.

Re-drafting, therefo

'=============
Public Sub Tester001A()
Dim rng As Range
Dim i As Long, j As Long

Set rng = Selection '<<==== CHANGE

If rng.Columns.Count 1 Then
Set rng = rng.Resize(, 1)
End If

For i = rng.Rows.Count To 1 Step -1
With rng(i)
If Not IsNumeric(.Offset(0, 1).Value) _
Or .Offset(0, 1).Value < 1 Then
'\\ Comment next code line to retain the row
'\\ for negative or alpha values
.Resize(1, 2).Delete shift:=xlUp
Else
j = .Offset(0, 1).Value
If j 1 And j - .Offset(0, 1).Value = 0 Then
.Offset(1).Resize(j - 1, 2).Insert shift:=xlDown
.Resize(1, 2).Copy Destination:=.Resize(j)
End If
End If
End With
Next i

End Sub
'<<=============

---
Regards,
Norman

just a small comment what if you wantto carry one 2 colums
ir
a b 1
c d 2 to become
a b
c d
c d ??

"Norman Jones" wrote:

Hi Toppers,

If we have a condition of j=1 then the code will error

You are correct. In my initial code, I used the a condition If j 1.I then
amended the code to allow for alpha and negative values and lost the initial
condition in the process!

Either 0 (blank) or 1 could be interpretted as leaving the entry "as-is"
bot not being mind readers ...!

Indeed it could - I was simply too lazy to add an appropriate comment line.
The suggested code also elides the potential problem of positive non-integer
values.

Re-drafting, therefo

'=============
Public Sub Tester001A()
Dim rng As Range
Dim i As Long, j As Long

Set rng = Selection '<<==== CHANGE

If rng.Columns.Count 1 Then
Set rng = rng.Resize(, 1)
End If

For i = rng.Rows.Count To 1 Step -1
With rng(i)
If Not IsNumeric(.Offset(0, 1).Value) _
Or .Offset(0, 1).Value < 1 Then
'\\ Comment next code line to retain the row
'\\ for negative or alpha values
.Resize(1, 2).Delete shift:=xlUp
Else
j = .Offset(0, 1).Value
If j 1 And j - .Offset(0, 1).Value = 0 Then
.Offset(1).Resize(j - 1, 2).Insert shift:=xlDown
.Resize(1, 2).Copy Destination:=.Resize(j)
End If
End If
End With
Next i

End Sub
'<<=============

---
Regards,
Norman

great Norman
thanks it worked.
"Norman Jones" wrote:

Hi Toppers,

If we have a condition of j=1 then the code will error

You are correct. In my initial code, I used the a condition If j 1.I then
amended the code to allow for alpha and negative values and lost the initial
condition in the process!

Either 0 (blank) or 1 could be interpretted as leaving the entry "as-is"
bot not being mind readers ...!

Indeed it could - I was simply too lazy to add an appropriate comment line.
The suggested code also elides the potential problem of positive non-integer
values.

Re-drafting, therefo

'=============
Public Sub Tester001A()
Dim rng As Range
Dim i As Long, j As Long

Set rng = Selection '<<==== CHANGE

If rng.Columns.Count 1 Then
Set rng = rng.Resize(, 1)
End If

For i = rng.Rows.Count To 1 Step -1
With rng(i)
If Not IsNumeric(.Offset(0, 1).Value) _
Or .Offset(0, 1).Value < 1 Then
'\\ Comment next code line to retain the row
'\\ for negative or alpha values
.Resize(1, 2).Delete shift:=xlUp
Else
j = .Offset(0, 1).Value
If j 1 And j - .Offset(0, 1).Value = 0 Then
.Offset(1).Resize(j - 1, 2).Insert shift:=xlDown
.Resize(1, 2).Copy Destination:=.Resize(j)
End If
End If
End With
Next i

End Sub
'<<=============

---
Regards,
Norman

mike
thanks it worked. I am not familiar with allof this so maybe you can bear
with me
do you know
if I had 2 or more colums to generate what could be the changes to do
I tried changing the desitnation string to D but gave me error
a b 2
a b
a b

"Mike Fogleman" wrote:

Stratis, You can try this. It worked in my test sample. It will put the
copies in column C and assumes your Original is in Columns A:B. It also
assumes the data starts in row 1 (no header). You can adjust the code
accordingly and delete columns A:B when done if you wish, or leave them
intact.

Sub CopyTimes()
Dim LRow As Long
Dim c As Range, SourceRng As Range, DestRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range("C" & CopyFrom & ":C" & CopyTo)
DestRng = c.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Stratis: This will do basically the same method, but will now use any number
of columns in your original data and place it in the next column following
your data. Since Excel only has 256 columns, this code will limit you to 128
columns of original data. If you think you will exceed this, and/or 65,536
rows, then we will need some more code to test for these limits.

Sub CopyTimes()
Dim LRow As Long, LCol As Long
Dim c As Range, SourceRng As Range, DestRng As Range, CopyRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
LCol = Range("A1").CurrentRegion.Columns.Count
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, LCol - 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range((Cells(CopyFrom, LCol + 1)), (Cells(CopyTo, (LCol * 2) -
1)))
Set CopyRng = Range((Cells(c.Row, c.Column)), (Cells(c.Row, LCol - 1)))
DestRng = CopyRng.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
mike
thanks it worked. I am not familiar with allof this so maybe you can bear
with me
do you know
if I had 2 or more colums to generate what could be the changes to do
I tried changing the desitnation string to D but gave me error
a b 2
a b
a b

"Mike Fogleman" wrote:

Stratis, You can try this. It worked in my test sample. It will put the
copies in column C and assumes your Original is in Columns A:B. It also
assumes the data starts in row 1 (no header). You can adjust the code
accordingly and delete columns A:B when done if you wish, or leave them
intact.

Sub CopyTimes()
Dim LRow As Long
Dim c As Range, SourceRng As Range, DestRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range("C" & CopyFrom & ":C" & CopyTo)
DestRng = c.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

Watch for word wrap on my Set DestRng = line. It was a little longer than
the other lines.
Mike F
"Mike Fogleman" wrote in message
...
Stratis: This will do basically the same method, but will now use any
number of columns in your original data and place it in the next column
following your data. Since Excel only has 256 columns, this code will
limit you to 128 columns of original data. If you think you will exceed
this, and/or 65,536 rows, then we will need some more code to test for
these limits.

Sub CopyTimes()
Dim LRow As Long, LCol As Long
Dim c As Range, SourceRng As Range, DestRng As Range, CopyRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
LCol = Range("A1").CurrentRegion.Columns.Count
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, LCol - 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range((Cells(CopyFrom, LCol + 1)), (Cells(CopyTo, (LCol *
2) - 1)))
Set CopyRng = Range((Cells(c.Row, c.Column)), (Cells(c.Row, LCol - 1)))
DestRng = CopyRng.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
mike
thanks it worked. I am not familiar with allof this so maybe you can bear
with me
do you know
if I had 2 or more colums to generate what could be the changes to do
I tried changing the desitnation string to D but gave me error
a b 2
a b
a b

"Mike Fogleman" wrote:

Stratis, You can try this. It worked in my test sample. It will put the
copies in column C and assumes your Original is in Columns A:B. It also
assumes the data starts in row 1 (no header). You can adjust the code
accordingly and delete columns A:B when done if you wish, or leave them
intact.

Sub CopyTimes()
Dim LRow As Long
Dim c As Range, SourceRng As Range, DestRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range("C" & CopyFrom & ":C" & CopyTo)
DestRng = c.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc

tks mike it does work

"Mike Fogleman" wrote:

Watch for word wrap on my Set DestRng = line. It was a little longer than
the other lines.
Mike F
"Mike Fogleman" wrote in message
...
Stratis: This will do basically the same method, but will now use any
number of columns in your original data and place it in the next column
following your data. Since Excel only has 256 columns, this code will
limit you to 128 columns of original data. If you think you will exceed
this, and/or 65,536 rows, then we will need some more code to test for
these limits.

Sub CopyTimes()
Dim LRow As Long, LCol As Long
Dim c As Range, SourceRng As Range, DestRng As Range, CopyRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
LCol = Range("A1").CurrentRegion.Columns.Count
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, LCol - 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range((Cells(CopyFrom, LCol + 1)), (Cells(CopyTo, (LCol *
2) - 1)))
Set CopyRng = Range((Cells(c.Row, c.Column)), (Cells(c.Row, LCol - 1)))
DestRng = CopyRng.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
mike
thanks it worked. I am not familiar with allof this so maybe you can bear
with me
do you know
if I had 2 or more colums to generate what could be the changes to do
I tried changing the desitnation string to D but gave me error
a b 2
a b
a b

"Mike Fogleman" wrote:

Stratis, You can try this. It worked in my test sample. It will put the
copies in column C and assumes your Original is in Columns A:B. It also
assumes the data starts in row 1 (no header). You can adjust the code
accordingly and delete columns A:B when done if you wish, or leave them
intact.

Sub CopyTimes()
Dim LRow As Long
Dim c As Range, SourceRng As Range, DestRng As Range
Dim CopyNum As Long, CopyFrom As Long, CopyTo As Long

LRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SourceRng = Range("A1:A" & LRow)
CopyFrom = 1

For Each c In SourceRng
CopyNum = c.Offset(0, 1).Value
CopyTo = CopyFrom + CopyNum - 1
Set DestRng = Range("C" & CopyFrom & ":C" & CopyTo)
DestRng = c.Value
CopyFrom = CopyFrom + CopyNum
Next c
End Sub

Mike F
"stratis" wrote in message
...
If I have an spreadsheet of the type
position 1 2
position 2 3
etc
is there a macro I can generate
position 1
position 1
position2
position2
position2
etc