Move A1 on every thrid row to a new column

  • Thread starter Thread starter Mickey
  • Start date Start date
M

Mickey

Hi,
I would appreciate any thoughts/help on this problem.

I have a series of data that is copied across from a database, this
populates three rows for each record of the database. I now need to copy
the contents of cell A3 into F3, this then repeats with each third row. For
example cell A3, A6, A9, would be copied across to F3, F6 & F9 etc, during
this process the 2nd & 3rd row are deleted.

In a nutshell the 2nd & 3rd row are deleted after the contents of the
required cell have been copied to another column. This then repeats for all
entries.

Thanks for any help,
Mickey
 
Mickey said:
Hi,
I would appreciate any thoughts/help on this problem.

I have a series of data that is copied across from a database, this
populates three rows for each record of the database. I now need to copy
the contents of cell A3 into F3, this then repeats with each third row. For
example cell A3, A6, A9, would be copied across to F3, F6 & F9 etc, during
this process the 2nd & 3rd row are deleted.

In a nutshell the 2nd & 3rd row are deleted after the contents of the
required cell have been copied to another column. This then repeats for all
entries.

Thanks for any help,
Mickey
Click to expand...

Try this on a copy of your real data.

Sub deletecells()

Application.ScreenUpdating = False

For Each cell In Worksheets("sheet1").Range([a1],
[a65536].End(xlUp)).Cells
If (cell.Row() Mod 3) <> 0 Then
cell.Value = ""
Else
cell.Offset(0, 5).Value = cell.Value
End If

Next cell

Application.ScreenUpdating = True

End Sub
 
Hi John,
Thx for that, however the code fails after For Each - I get an error that
the variable 'cell' has not been defined.

The following ode does the job but is obvioulsy inefficent - any thoughts?

Sub Macro1()
'
' Macro1 Macro
' Macro recorded 24/11/2006 by MB'

'
Sheets("Sheet1 (3)").Select
Range("A3").Select
Selection.Cut
Range("E1").Select
ActiveSheet.Paste
Rows("2:3").Select
Selection.Delete Shift:=xlUp
Range("A4").Select
Selection.Cut
Range("E2").Select
ActiveSheet.Paste
Rows("3:4").Select
Selection.Delete Shift:=xlUp
Range("A5").Select
Selection.Cut
Range("E3").Select
ActiveSheet.Paste
Rows("4:5").Select
Selection.Delete Shift:=xlUp
End Sub

Best Wishes,
Mickey


John Smith said:
Mickey said:
Hi,
I would appreciate any thoughts/help on this problem.

I have a series of data that is copied across from a database, this
populates three rows for each record of the database. I now need to copy
the contents of cell A3 into F3, this then repeats with each third row.
For
example cell A3, A6, A9, would be copied across to F3, F6 & F9 etc,
during
this process the 2nd & 3rd row are deleted.

In a nutshell the 2nd & 3rd row are deleted after the contents of the
required cell have been copied to another column. This then repeats for
all
entries.

Thanks for any help,
Mickey
Click to expand...

Try this on a copy of your real data.

Sub deletecells()

Application.ScreenUpdating = False

For Each cell In Worksheets("sheet1").Range([a1],
[a65536].End(xlUp)).Cells
If (cell.Row() Mod 3) <> 0 Then
cell.Value = ""
Else
cell.Offset(0, 5).Value = cell.Value
End If

Next cell

Application.ScreenUpdating = True

End Sub
Click to expand...
 
Public Sub ProcessData()
Dim iLastRow As Long
Dim i As Long
Dim rng As Range

With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow Step 3
If rng Is Nothing Then
Set rng = Rows(i + 1).Resize(2)
Else
Set rng = Union(rng, Rows(i + 1).Resize(2))
End If
Cells(i, "A").Copy Cells(i, "F")

If Not rng Is Nothing Then rng.Delete
End With

End Sub

--

HTH

Bob Phillips

(replace xxxx in the email address with gmail if mailing direct)
 
Thanks Bob,
When 'run I get a Compile Error saying - End With without With

Any ideas?, I've had a stab at a few things but .........

Thanks for your help,
Mickey
 
My error, I missed a Next i

Public Sub ProcessData()
Dim iLastRow As Long
Dim i As Long
Dim rng As Range

With ActiveSheet
iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow Step 3
If rng Is Nothing Then
Set rng = Rows(i + 1).Resize(2)
Else
Set rng = Union(rng, Rows(i + 1).Resize(2))
End If
Cells(i, "A").Copy Cells(i, "F")
Next i

If Not rng Is Nothing Then rng.Delete
End With

End Sub

--

HTH

Bob Phillips

(replace xxxx in the email address with gmail if mailing direct)
 
Back
Top