run time error 424: object required error when copying and pasting based on a condition

Question

Hello,
I've created the code below for use with the worksheet I've mocked up for you.
The code runs fine until I get to the ActiveCell.Cells.Select.Copy.ActiveCell.Offset(0, 1).Select.Paste Else
statement in the next to the last line.
The procedure associated with this line is supposed to act as follows:
In column B, beginning with cell B8, evaluate each of the next 130 cells in the same column
to determine if a cell is or is not blank.
If a cell is not blank, copy its contents to the cell immediately to the right of it, in the same row, in column C.
If a cell is blank, go to the next cell in column B and evaluate it using the same criteria.
No matter what tweaks I make to the statement, I keep getting Run-time error '424': object required.
I'm sure there is a very obvious solution to this. I just can't seem to figure it out.
Any assistance anyone can provide would be very much appreciated.
Here's the code:
Sheets("MW").Select
Cells.Select
Selection.MergeCells = False
Sheets("MW").Select
Cells.Select
Columns("A:XFD").Hidden = False
Sheets("MW").Select
Cells.Select
Selection.HorizontalAlignment = xlLeft
Range("B1").End(xlDown).Offset(2, 2).Select
For ct = 1 To 160
If ActiveCell.Value = "" Then ActiveCell.EntireColumn.Delete Shift:=xlToLeft Else ActiveCell.Offset(0, 1).Select
Next ct
Range("B1").End(xlDown).Offset(4, 0).Select
For ct = 1 To 130
If ActiveCell.Value <> "" Then ActiveCell.Cells.Select.Copy.ActiveCell.Offset(0, 1).Select.Paste Else ActiveCell.Offset(1, 0).Select
Next ct
And here's a mockup of the worksheet I'm using:
A	B	C	D
1		Division
2
3		02/01/2013 to 02/26/2013
4		Breakdown
5				HUC
6	****			Total
7				Hrs
8		aaaaa
9			xx	18,779
10			xxx	16,216
11			xxxx	1,197
12			xxxx	26,655
13			xxxxx	2,373
14	****		xxxxxx	65,220
15
16		bbbbb
17			xx	20,007
Thanks!!
Jane

Answer 1

Hi Andreas,

Thank you so much! I won't have a chance to attempt this until I return to work, Monday morning. I'll do as you describe however, once I get there, and will let you know how I fare.

Thanks again. Jane

Answer 2

Never use SELECT and SELECTION in your macros, it's slow and error prone!

I can not accurately recognize what you really want, so I have to guess a little. Please study the comments in the macro below, and execute it step by step (by pressing F8), means debug that macro and look what happens.

If you never debugged a macro, have a look at this tutorial, especially the section "Debugging in VBA".

http://www.wiseowl.co.uk/blog/s161/online-excel-vba-training.htm

Andreas.

Sub Test()

  Dim R As Range, Total As Range

  Dim i As Long

  'In this sheet

  With Sheets("MW")

    'Access the used range

    With .UsedRange

      'Prepare the cells

      .MergeCells = False

      .Columns.Hidden = False

      .HorizontalAlignment = xlLeft

    End With

    'Find "Total" in column D

    Set Total = .Columns("D").Find("Total", LookIn:=xlValues, LookAt:=xlWhole)

    'Found?

    If Total Is Nothing Then

      MsgBox "Total not found!"

      Exit Sub

    End If

    'Include the next 160 columns and find all empty cells

    Set R = SpecialCells(Total.Resize(1, 160), xlCellTypeBlanks)

    'Delete this columns if cells found

    If Not R Is Nothing Then R.EntireColumn.Delete

    'Below "Total" is "Hrs", go below that into column B

    Set R = Total.Offset(3, -2)

    'Start from this cell 130 rows downwards

    For i = 0 To 129

      'Is the cell empty?

      If Not IsEmpty(R.Offset(i)) Then

        'Write the value to the right (column C)

        R.Offset(i, 1) = R.Offset(i)

      End If

    Next

  End With

End Sub

Private Function SpecialCells(ByVal R As Range, ByVal Typ As XlCellType, _

    Optional ByVal Value As XlSpecialCellsValue = &H17) As Range

  'Avoid the SpecialCells-BUG to return all cells from the current region

  On Error Resume Next

  Select Case Typ

    Case xlCellTypeConstants, xlCellTypeFormulas

      Set SpecialCells = Intersect(R, R.SpecialCells(Typ, Value))

    Case Else

      Set SpecialCells = Intersect(R, R.SpecialCells(Typ))

  End Select

End Function