| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
paste object failed
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
paste object failed
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("Which Sheet") sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1") NickHK "Lp12" wrote in message ... 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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
paste object failed
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" wrote: 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("Which Sheet") sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1") NickHK "Lp12" wrote in message ... 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 |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
paste object failed
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 "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" wrote: 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("Which Sheet") sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1") NickHK "Lp12" wrote in message ... 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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
paste object failed
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, 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" wrote: 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("Which Sheet") sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1") NickHK "Lp12" wrote in message ... 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 |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
paste object failed
Hi Nick,
i've done it and got the "Paste of object worksheet failed" error 2147417848. Still cannot figure it out...:( "NickHK" wrote: 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, 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" wrote: 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("Which Sheet") sourcews.Range("A2:AC2").Copy destination:=WB.worksheets(1).Range("A1") NickHK "Lp12" wrote in message ... 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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Paste Method of Worksheet Failed When Copying Chart Object | Excel Discussion (Misc queries) | |||
| run-time error, method 'paste' of object - worksheet failed. | Excel Programming | |||
| Error in Macro: "Method 'Paste' of object '_Worksheet' failed" | Excel Programming | |||
| Method 'Paste' of object '_Worksheet' failed | Excel Discussion (Misc queries) | |||
| Method 'Paste' of object '_worksheet' failed | Excel Programming | |||
Linear Mode
