Macro to Copy Cells

[Jim]

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

 

[Tom Ogilvy]

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.

 

[Jim]

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-----

 

[Tom Ogilvy]

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

 

[Jim]

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






.