Macro that deletes every third row....+

[ajjag]

I am fairly new to creating macros and am stuck on something...

Here is the sequence that I want to follow:

1. I need to delete every third starting at row 3 (3,6,9,12,etc) and
move information up
2. Cut and paste every other cell starting at A2......A300 i.e.
(2,4,6,etc) after those cells from part 1 have been moved up and moved
over to column B starting at B1 with no spaces between the information

3. Then the newly blanks cells in column A need to be moved up....

Is it then possible to take the first 12 spaces of the cells in column
B and move them over to column C?

Sorry if I put too much for a first post but I am stuck.

Thanks to anyone who can help

 

[Guest]

This will delete entire rows (not just cells in a column) in every 3rd row as
they are numbered when it starts.

This means that #3 in your request is already taken care of.

Sub DeleteEvery3rdRow()
'presumes you're on the sheet before
'starting
Dim LastRowNowInUse As Long

LastRowNowInUse = Selection.SpecialCells(xlCellTypeLastCell).Row
Application.ScreenUpdating = False
Range("A3").Select ' go to row 3
Selection.EntireRow.Delete
'now that deleted the entire row and
'moved all others up, so we only need
'to move down 2 rows from now on
Do Until ActiveCell.Row > LastRowNowInUse
ActiveCell.Offset(2, 0).Activate
Selection.EntireRow.Delete
Loop
Application.ScreenUpdating = True

End Sub

For the unnumbered #4, Yes: in cell C1 use the formula
=LEFT(B1,12)
and extend down the sheet.

working on code to include with the above to accomplish both your move from
column A to B and the 12 character copy into column C. Back later with that.

 

[Guest]

Here's a second segment of code that will take care of both part 2 and the
move 12
spaces of cells in column B into C.

Sub MoveEveryOtherCellsData(LastRowNowInUse As Long)
'
'now to copy every other cell content from A2, A4 over
'to column B
Dim AOffset As Long
Dim BOffset As Long
Dim strTest As String

AOffset = 0 ' initialize to zero
BOffset = 0 ' initialize to zero

Range("A2").Select
Do Until BOffset > LastRowNowInUse
Range("B1").Offset(BOffset, 0) = _
Range("A2").Offset(AOffset, 0)
'and while we are at it, take the 1st 12 characters of entry just
'moved into column B and put them into column C
On Error Resume Next
strTest = Range("B1").Offset(BOffset, 0)
If Err <> 0 Then
Err.Clear
Range("B1").Offset(BOffset, 1) = _
Range("B1").Offset(BOffset, 0)
Else
If Len(strTest) > 11 Then
Range("B1").Offset(BOffset, 1) = _
Left(Range("B1").Offset(BOffset, 0), 12)
Else
Range("B1").Offset(BOffset, 1) = _
Range("B1").Offset(BOffset, 0)
End If
End If
On Error GoTo 0 ' clear error trapping
AOffset = AOffset + 2
BOffset = BOffset + 1
Loop

End Sub

insert this line just before the Application.ScreenUpdating = True statement
in the previous routine:
MoveEveryOtherCellsData LastRowNowInUse

and the first routine will call the second one before finishing up.

 

[ajjag]

You guys are awesome. Most of this worked except the last segment
doesn't repeat. Every third row deletes and then it will take A2 and
move it to B1 and then take the first 12 characters and move them to
C1. How can we make it repeat? I need _all_ the even numbered A column
cells to be moved over and then consolidate the A column. For Example
(after every third line has been deleted):

APPLE
123456789456 ABC
BANANA
321654987321 DEF
CARROT
456789123456 GHI
DOG
321654987987 JKL

APPLE 123456789456 ABC
321654987321 DEF
BANANA 456789123456 GHI
321654987987 JKL
CARROT

DOG

APPLE 123456789456 ABC 123456789456
BANANA 321654987321 DEF 321654987321
CARROT 456789123456 GHI 456789123456
DOG 321654987987 JKL 321654987987

Let me know what you think.

Thanks again.

 

[ajjag]

Spoke to soon. It does repeat but I need those even numbered cells to go
away and move up the information in column A. For example:

APPLE
12465896432131 ABC
BANANA
12345678954321 DEF
CARROT
12345687931 GHI
DOG
1235468895461 JKL

BECOMES:
APPLE 12465896432131 ABC 12465896432131
BANANA 12345678954321 DEF 12345678954321
CARROT 12345687931 GHI 12345687931
DOG 1235468895461 JKL 1235468895461

THANK YOU THANK YOU THANK YOU

This will make my life much easier