Copying Down and Across

[Robert Gillard]

Problem,

I have a problem with a spreadsheet that comes down the page in
"steps".(If you had a blank sheet of paper turn it landscape and draw a line
from the bottom left hand corner to the top right hand corner and just look
at the area above the line - that's the shape of the spreadsheet.)

Each month I have to add a new step to those already there. Each step is
4 cols wide and 6 rows down, so for example this month I would highlight
cells A100105 and then drag down so the new cells are A106111. I now go
to the next step which would be from E94:H99 highlight the cells and
dragdown to E100:H105.......and so on across the page.

Can I automate this process if so how.... cause this is a big spreadsheet.

With thanks

Bob

 

[keepitcool]

Bob,
this should do it:

Sub FillSheet()
Dim r&, n&
With ActiveSheet
For r = [a65536].End(xlUp).Row To 1 Step -6
.Cells(r, 4 * n + 1).Resize(6 * (n + 1), 4).FillDown
n = n + 1
If Intersect(.Cells(r, 4 * n + 1), .UsedRange) Is Nothing Then
Exit For
End If
Next
End With
End Sub


keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >

 

[Leo Heuser]

Bob

I'm not sure, what you mean by "drag down" (move or copy??),
but this code may get you started:

Sub InsertNewStep()
'Leo Heuser, 16 Sept. 2003
Dim StepBlock As Range

Set StepBlock = Sheets("Ark2"). _
Cells(ActiveSheet.Rows.Count, 1). _
End(xlUp).Offset(-5, 0).Resize(6, 4)

On Error Resume Next

Do
StepBlock.Offset(6, 0).Interior.ColorIndex = 3
Set StepBlock = StepBlock.Offset(-6, 4)
Loop Until Err.Number > 0

On Error GoTo 0

End Sub



--
Best Regards
Leo Heuser
MVP Excel

Followup to newsgroup only please.

 

[Robert Gillard]

Excellent ... a really big thank you it was exactly what I wanted.

Bob

 

[Robert Gillard]

Zantor,

Test file worked great, but when I try to apply it to actual file
nothing happens. What I omitted to mention in my post was that the actual
spreadsheet did not start until C17, I have tried to "fiddle" with it but
cannot correctly set the start Range.

I apologise for not being precise enough in my initial post, is it
possible that you could again assist me.

with thanks

Bob


Sub CopyMyCells1()
Dim r, c As Integer
r = 1
c = 1

Do Until Cells(r, c) = ""

Do Until Cells(r, c) = ""
r = r + 1
Loop
Cells(r - 6, c).Select
Range(Cells(r - 6, c), Cells(r - 1, c + 3)).Copy
Cells(r, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
c = c + 4
r = 1
Loop

End Sub

 

[zantor]

Hi Robert,

You need to set r=17 at the beginning of the sub and at the end.

Sub CopyMyCells1()
Dim r, c As Integer
r = 17
c = 1

Do Until Cells(r, c) = ""

Do Until Cells(r, c) = ""
r = r + 1
Loop
Cells(r - 6, c).Select
Range(Cells(r - 6, c), Cells(r - 1, c + 3)).Copy
Cells(r, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
c = c + 4
r = 17
Loop

End Sub