paste object failed

[Lp12]

Hi All,
I wrote a code that copy rows from a spreadsheet to a CSV file.
One station with OfficeXP SP3 gets the above message, all other Office XP or
Office2003 stations succeed.
Any thoughts?

Sub CreateCSV()
On Error GoTo ErrorHandler

'Check for the validity of the the payroll date
Range("C1").Select
Do
If ActiveCell.Value = "Ending Period:" Then
Exit Do
Else: ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = "Ending Period:"
PeriodDate = ActiveCell.Offset(0, 1).Value
If DateDiff("d", PeriodDate, Date) > 5 Then
Response = MsgBox("The Payroll period is incorrect,Do you wish to
continue?", vbOKCancel)
If Response = vbOK Then
GoTo ClickOK
Else
Exit Sub
End If
End If
ClickOK:
fname = "C:/ADP/PCPW/ADPDATA/EPIYDPMP"
Application.ScreenUpdating = False
'checks if an ADP folder exists, If not creates one
ADPDir = Dir("C:\ADP\", vbDirectory)
If ADPDir <> "." Then 'ADP exists
MkDir "C:\ADP"
If Len(Dir("C:\ADP\PCPW", vbDirectory)) = 0 Then
MkDir "C:\ADP\PCPW"
End If
If Len(Dir("C:\ADP\PCPW\ADPDATA", vbDirectory)) = 0 Then
MkDir "C:\ADP\PCPW\ADPDATA"
End If
End If
ADPDir = Dir("C:\ADP\PCPW\", vbDirectory)
If ADPDir <> "." Then 'ADP\PCPW exists
MkDir "C:\ADP\PCPW"
If Len(Dir("C:\ADP\PCPW\ADPDATA", vbDirectory)) = 0 Then
MkDir "C:\ADP\PCPW\ADPDATA"
End If
End If
ADPDir = Dir("C:\ADP\PCPW\ADPDATA\", vbDirectory)
If ADPDir <> "." Then 'ADP\PCPW\ADPDATA exists
MkDir "C:\ADP\PCPW\ADPDATA"
End If
wbname = ActiveWorkbook.Name
Windows(wbname).Activate
shname = ActiveSheet.Name
Sheets(shname).Select
Range("A2:AC2").Select
Selection.Copy
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste
Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:=xlCSV, CreateBackup:=False
Windows(wbname).Activate
Range("A2").Select
Do Until ActiveCell.Value = "Total"
ActiveCell.Offset(1, 0).Select
curraddress = ActiveCell.Address
curr = ActiveCell.Row
If ActiveCell.Value = "Total" Then
' Delete unuse column
Windows("EPIYDPMP.csv").Activate
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("a1").Select
Rows("2:100").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("a1").Select
ActiveWorkbook.Save
MsgBox "Done"
Exit Sub
End If
Range("A" & curr & ":AC" & curr).Copy
' Checking the flag for a empty record
If ActiveCell.Offset(0, 29).Value <> "" Then
curr = ActiveCell.Row
Range("A" & curr & ":AC" & curr).Copy
Windows("EPIYDPMP.csv").Activate
Range("A1").Select
'Goto available row
Do
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = ""
'ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Windows(wbname).Activate
Else
' active row isnt releavant, so skipping it
Windows(wbname).Activate
'ActiveCell.Offset(1, 0).Select
End If
Loop

ErrorHandler: ' Error-handling routine.
Select Case Err.Number ' Evaluate error number.
Case 1004 ' "File already open" error.
MsgBox "The CSV file is already open, Please close it first and
try again" ' Close open file.
Exit Sub
Case Else
' Handle other situations here...
End Select
Resume ' Resume execution at same line
' that caused the error.

End Sub

 

[NickHK]

Err, which line causes the error as you have a few pastes ?

Also, you will code much easier if you do not .select all these objects; it
is seldom necessary and slows down execution.
And Range("A1").End(xlDown) will get you to the end of the column instead of
looping until you get an empty cell.
There is the .Find method which makes it easy to search for specific text

So:
Dim MyRange As Range

On Error Resume Next
Set MyRange = Range("C:C").Find("Ending Period:", Range("C1"), xlPart)
If MyRange Is Nothing Then
MsgBox "No start value found"
Exit Sub
End If
PeriodDate = MyRange.Offset(0, 1).Value

'...etc
You can simplify the folder creation with the CreateDirectory API
http://vbnet.mvps.org/code/file/nested.htm

'Give your some private objects to clean up the code
Dim WB as workbook
dim SourceWS as worksheet
Set wb=workbooks.add
set sourcews=Workbooks("Source.xls").worksheets("WhichSheet")
sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1")

NickHK

 

[Lp12]

Hi Nick,
Thanks a lot fot the tips I will review them.
The problem seems to be in the PasteScpecial object. Do you think of a
reason why in one station its working and in another it doesn't?
tnx again

 

[NickHK]

You may want to return DisplayAlerts to True, after you have deleted the
sheets. Excel may be trying to you something, but you are preventing it.

Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True

NickHK

 

[NickHK]

Also, your error handler has a Resume at the end. So if an error other than
1004 occur, you will never know.
Put a
Debug.Print "Error : " & err.number & vbnewline & err.description
in the Case Else, so at least can see if an error is raised.

NickHK

 

[Lp12]

Hi Nick,
i've done it and got the "Paste of object worksheet failed" error 2147417848.
Still cannot figure it out...