Macro to Copy Cells
 

I need a macro to look at a row of cells, copy them based
on a number in the last cell in that row and insert them
that many times. Then go to the next cell and do the same
thing. I'm struggling with this one guys.

PUBLIC AFFAIRS OFFICE 87
GERRITY MEMORIAL LIBRARY 6
ATTN. TECH SGT. KAREN KAYLOR 106
PUBLIC AFFAIRS 3
112TH MED CO 6
1-152ND MAINT CO 6
DET 2, 152ND MAINTENANCE COMPANY 6
1136TH TRANS CO 6

Thanks a million,
Jim

Macro to Copy Cells
 

Assume your data is on Sheet3 and sheet2 is where the expanded entries will
be placed.

Option Explicit
Sub ExpandData()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
rng1.Resize(cell1.Value, 1) = cell.Value
End With
Next
End Sub


worked for me.

--
Regards,
Tom Ogilvy



"Jim" wrote in message
...
I need a macro to look at a row of cells, copy them based
on a number in the last cell in that row and insert them
that many times. Then go to the next cell and do the same
thing. I'm struggling with this one guys.

PUBLIC AFFAIRS OFFICE 87
GERRITY MEMORIAL LIBRARY 6
ATTN. TECH SGT. KAREN KAYLOR 106
PUBLIC AFFAIRS 3
112TH MED CO 6
1-152ND MAINT CO 6
DET 2, 152ND MAINTENANCE COMPANY 6
1136TH TRANS CO 6

Thanks a million,
Jim

Macro to Copy Cells
 

Thanks Tom, but it does not seem to work. My range of
data is from A to E with the number of times I need them
copied in F.

Thanks Again,
Jim
-----Original Message-----
Assume your data is on Sheet3 and sheet2 is where the
expanded entries will
be placed.

Option Explicit
Sub ExpandData()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
rng1.Resize(cell1.Value, 1) = cell.Value
End With
Next
End Sub


worked for me.

--
Regards,
Tom Ogilvy



"Jim" wrote in message
...
I need a macro to look at a row of cells, copy them
based
on a number in the last cell in that row and insert
them
that many times. Then go to the next cell and do the
same
thing. I'm struggling with this one guys.

PUBLIC AFFAIRS OFFICE 87
GERRITY MEMORIAL LIBRARY 6
ATTN. TECH SGT. KAREN KAYLOR 106
PUBLIC AFFAIRS 3
112TH MED CO 6
1-152ND MAINT CO 6
DET 2, 152ND MAINTENANCE COMPANY 6
1136TH TRANS CO 6

Thanks a million,
Jim



.

Macro to Copy Cells
 

Sub ExpandData1()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
cell.Parent.Range(cell, cell1).Copy rng1.Resize(cell1.Value, 1)
End With
Next
End Sub

--
Regards,
Tom Ogilvy



"Jim" wrote in message
...
Thanks Tom, but it does not seem to work. My range of
data is from A to E with the number of times I need them
copied in F.

Thanks Again,
Jim
-----Original Message-----
Assume your data is on Sheet3 and sheet2 is where the
expanded entries will
be placed.

Option Explicit
Sub ExpandData()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
rng1.Resize(cell1.Value, 1) = cell.Value
End With
Next
End Sub


worked for me.

--
Regards,
Tom Ogilvy



"Jim" wrote in message
...
I need a macro to look at a row of cells, copy them
based
on a number in the last cell in that row and insert
them
that many times. Then go to the next cell and do the
same
thing. I'm struggling with this one guys.

PUBLIC AFFAIRS OFFICE 87
GERRITY MEMORIAL LIBRARY 6
ATTN. TECH SGT. KAREN KAYLOR 106
PUBLIC AFFAIRS 3
112TH MED CO 6
1-152ND MAINT CO 6
DET 2, 152ND MAINTENANCE COMPANY 6
1136TH TRANS CO 6

Thanks a million,
Jim



.

Macro to Copy Cells
 

You are the man !!!!


-----Original Message-----
Sub ExpandData1()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
cell.Parent.Range(cell, cell1).Copy rng1.Resize
(cell1.Value, 1)
End With
Next
End Sub

--
Regards,
Tom Ogilvy



"Jim" wrote in
message
...
Thanks Tom, but it does not seem to work. My range of
data is from A to E with the number of times I need
them
copied in F.

Thanks Again,
Jim
-----Original Message-----
Assume your data is on Sheet3 and sheet2 is where the
expanded entries will
be placed.

Option Explicit
Sub ExpandData()
Dim rng As Range, cell As Range
Dim cell1 As Range, rng1 As Range
With Worksheets("Sheet3")
Set rng = .Range(.Cells(1, 1), .Cells(1, 1).End
(xlDown))
End With
For Each cell In rng
Set cell1 = rng.Parent.Cells(cell.Row, 256).End
(xlToLeft)
With Worksheets("Sheet2")
Set rng1 = .Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(rng1) Then
Set rng1 = rng1.Offset(1, 0)
End If
rng1.Resize(cell1.Value, 1) = cell.Value
End With
Next
End Sub


worked for me.

--
Regards,
Tom Ogilvy



"Jim" wrote in message
...
I need a macro to look at a row of cells, copy them
based
on a number in the last cell in that row and insert
them
that many times. Then go to the next cell and do the
same
thing. I'm struggling with this one guys.

PUBLIC AFFAIRS OFFICE 87
GERRITY MEMORIAL LIBRARY 6
ATTN. TECH SGT. KAREN KAYLOR 106
PUBLIC AFFAIRS 3
112TH MED CO 6
1-152ND MAINT CO 6
DET 2, 152ND MAINTENANCE COMPANY 6
1136TH TRANS CO 6

Thanks a million,
Jim



.



.