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