ActiveSheet.Paste error

  • Thread starter Thread starter Robb
  • Start date Start date
R

Robb

I have a consolidation routine that will, if the user chooses, consolidate the output of all the
sheets in our generated report onto one sheet by appending them one after the other with the
ActiveSheet.Paste method. It has been working fine with no problems until one customer generated a
LOT of reports which means a lot of worksheets in the book and a lot of calls to cut and paste them
all onto one sheet. Through trial and error I found that my machine can handle 90 reports (90
worksheets pasted into one sheet via a loop) before the error occurs. The customer was generating 92
reports (but I do not know at what point the error occurred for him).

The runtime error is:
Method 'Paste' of object '_Worksheet' failed

On a few occasions the same .paste call generated this error first:
No more new fonts may be applied in this workbook.

I'm guessing it is related to available resources somehow but exactly what I have no idea.
Monitoring the system memory shows no increase as the program runs. After 50 or so iterations I do
notice a progressive slowdown beginning.

Here is the code that does the consolidation. The error occurs on the ActiveSheet.Paste call.

Robb
========================================================


Private Sub ConsolidateSheets(SourceWB As Workbook)
'CONSOLIDATES ALL REPORT SHEETS OF PASSED WORKBOOK ONTO ONE SHEET
Dim I As Integer
Dim R As Integer
Dim C As Integer
Dim CurrentRow As Integer
Dim MasterSheet As Worksheet
Dim FoundMasterSheet As Boolean

FoundMasterSheet = False
For I = 1 To SourceWB.Sheets.Count 'LOOP THROUGH ALL SHEETS OF PASSED WORKBOOK
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then 'FIND FIRST REPORT SHEET
If FoundMasterSheet = False Then
FoundMasterSheet = True
Set MasterSheet = SourceWB.Sheets(I)
Set SPC_RS = SourceWB.Sheets(I)
MasterSheet.PageSetup.Zoom = False
MasterSheet.PageSetup.FitToPagesWide = 1
MasterSheet.PageSetup.Zoom = 80
Else 'FIRST REPORT SHEET ALREADY FOUND. NOW COPY TO IT
CurrentRow = GetLastUsedRowCol(MasterSheet, "ROW") + 2 'GET ROW TO COPY TO
R = GetLastUsedRowCol(SourceWB.Sheets(I), "ROW") 'GET RANGE OF CELLS TO COPY
C = GetLastUsedRowCol(SourceWB.Sheets(I), "COL")
SourceWB.Sheets(I).Activate 'SWITCH TO REPORT SHEET TO COPY FROM
SourceWB.Sheets(I).Range(GetRangeString(1, 1, C, R)).Select 'SELECT DATA
Selection.Copy 'COPY DATA
MasterSheet.Activate 'SWITCH TO REPORT SHEET TO COPY TO
MasterSheet.Cells(CurrentRow, 1).Select 'SET LOCATION TO PASTE TO
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell 'SET A PAGE BREAK
ActiveSheet.Paste 'PASTE DATA
End If
End If
Next I

ActiveSheet.PageSetup.FitToPagesWide = 1

On Error Resume Next 'DELETE SHEETS THAT WERE COPIED
Application.DisplayAlerts = False
For I = SourceWB.Sheets.Count To 1 Step -1
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then
If SourceWB.Sheets(I).Name <> MasterSheet.Name Then
SourceWB.Sheets(I).Delete
End If
End If
Next I
Application.DisplayAlerts = True
On Error GoTo 0

MasterSheet.Cells(1, 1).Select 'SELECT CELL A,1 (AESTHETIC REASONS ONLY)

End Sub


Public Function GetLastUsedRowCol(WS As Worksheet, RowOrCol As String) As Variant
'RETURNS THE NUMBER OF THE LAST ROW IN THE SPECIFIED WORKSHEET'S USEDRANGE
Dim CellWasEmpty As Boolean

CellWasEmpty = (WS.Cells(1, 1) = "") 'CELL(1,1) IS EMPTY

If CellWasEmpty Then 'IF CELL IS EMPTY, THEN TEMP FILL IT
WS.Cells(1, 1) = "."
End If

Select Case UCase(RowOrCol)
Case "ROW": GetLastUsedRowCol = WS.UsedRange.Rows.Count
Case "COL": GetLastUsedRowCol = WS.UsedRange.Columns.Count
Case Else: MsgBox "Invalid value [" & RowOrCol & "] passed." & vbCrLf & _
"Module: modTarus" & vbCrLf & _
"Function: GetLastUsedRowCol", vbCritical, "Program Error"
GetLastUsedRowCol = 0
End Select

If CellWasEmpty Then WS.Cells(1, 1).Clear 'IF CELL WAS ORIGINALLY EMPTY, THEN EMPTY IT AGAIN

End Function


========================================================
 
Sometimes when you do things in excel, the cutcopymode flag is reset.

For instance, I copied a range, then added a page break. As soon as I added
that page break, the marching ants disappeared from my copied range.

I'd try changing the order of these statements:

ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveSheet.Paste

So that you paste first, then add the page break.


I have a consolidation routine that will, if the user chooses, consolidate the output of all the
sheets in our generated report onto one sheet by appending them one after the other with the
ActiveSheet.Paste method. It has been working fine with no problems until one customer generated a
LOT of reports which means a lot of worksheets in the book and a lot of calls to cut and paste them
all onto one sheet. Through trial and error I found that my machine can handle 90 reports (90
worksheets pasted into one sheet via a loop) before the error occurs. The customer was generating 92
reports (but I do not know at what point the error occurred for him).

The runtime error is:
Method 'Paste' of object '_Worksheet' failed

On a few occasions the same .paste call generated this error first:
No more new fonts may be applied in this workbook.

I'm guessing it is related to available resources somehow but exactly what I have no idea.
Monitoring the system memory shows no increase as the program runs. After 50 or so iterations I do
notice a progressive slowdown beginning.

Here is the code that does the consolidation. The error occurs on the ActiveSheet.Paste call.

Robb
========================================================

Private Sub ConsolidateSheets(SourceWB As Workbook)
'CONSOLIDATES ALL REPORT SHEETS OF PASSED WORKBOOK ONTO ONE SHEET
Dim I As Integer
Dim R As Integer
Dim C As Integer
Dim CurrentRow As Integer
Dim MasterSheet As Worksheet
Dim FoundMasterSheet As Boolean

FoundMasterSheet = False
For I = 1 To SourceWB.Sheets.Count 'LOOP THROUGH ALL SHEETS OF PASSED WORKBOOK
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then 'FIND FIRST REPORT SHEET
If FoundMasterSheet = False Then
FoundMasterSheet = True
Set MasterSheet = SourceWB.Sheets(I)
Set SPC_RS = SourceWB.Sheets(I)
MasterSheet.PageSetup.Zoom = False
MasterSheet.PageSetup.FitToPagesWide = 1
MasterSheet.PageSetup.Zoom = 80
Else 'FIRST REPORT SHEET ALREADY FOUND. NOW COPY TO IT
CurrentRow = GetLastUsedRowCol(MasterSheet, "ROW") + 2 'GET ROW TO COPY TO
R = GetLastUsedRowCol(SourceWB.Sheets(I), "ROW") 'GET RANGE OF CELLS TO COPY
C = GetLastUsedRowCol(SourceWB.Sheets(I), "COL")
SourceWB.Sheets(I).Activate 'SWITCH TO REPORT SHEET TO COPY FROM
SourceWB.Sheets(I).Range(GetRangeString(1, 1, C, R)).Select 'SELECT DATA
Selection.Copy 'COPY DATA
MasterSheet.Activate 'SWITCH TO REPORT SHEET TO COPY TO
MasterSheet.Cells(CurrentRow, 1).Select 'SET LOCATION TO PASTE TO
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell 'SET A PAGE BREAK
ActiveSheet.Paste 'PASTE DATA
End If
End If
Next I

ActiveSheet.PageSetup.FitToPagesWide = 1

On Error Resume Next 'DELETE SHEETS THAT WERE COPIED
Application.DisplayAlerts = False
For I = SourceWB.Sheets.Count To 1 Step -1
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then
If SourceWB.Sheets(I).Name <> MasterSheet.Name Then
SourceWB.Sheets(I).Delete
End If
End If
Next I
Application.DisplayAlerts = True
On Error GoTo 0

MasterSheet.Cells(1, 1).Select 'SELECT CELL A,1 (AESTHETIC REASONS ONLY)

End Sub

Public Function GetLastUsedRowCol(WS As Worksheet, RowOrCol As String) As Variant
'RETURNS THE NUMBER OF THE LAST ROW IN THE SPECIFIED WORKSHEET'S USEDRANGE
Dim CellWasEmpty As Boolean

CellWasEmpty = (WS.Cells(1, 1) = "") 'CELL(1,1) IS EMPTY

If CellWasEmpty Then 'IF CELL IS EMPTY, THEN TEMP FILL IT
WS.Cells(1, 1) = "."
End If

Select Case UCase(RowOrCol)
Case "ROW": GetLastUsedRowCol = WS.UsedRange.Rows.Count
Case "COL": GetLastUsedRowCol = WS.UsedRange.Columns.Count
Case Else: MsgBox "Invalid value [" & RowOrCol & "] passed." & vbCrLf & _
"Module: modTarus" & vbCrLf & _
"Function: GetLastUsedRowCol", vbCritical, "Program Error"
GetLastUsedRowCol = 0
End Select

If CellWasEmpty Then WS.Cells(1, 1).Clear 'IF CELL WAS ORIGINALLY EMPTY, THEN EMPTY IT AGAIN

End Function

========================================================
Click to expand...
 
Dave,

Thanks for the reply and the suggestion. Unfortunately it made no difference. It is still the 91st
iteration that breaks it every time. For grins I even removed the pagebreak line altogether. Still
broke on the 91st iteration. I also ruled out the possibility of data being the problem by changing
the loop to run backward through the sheets as well as trying different data.

Robb


Sometimes when you do things in excel, the cutcopymode flag is reset.

For instance, I copied a range, then added a page break. As soon as I added
that page break, the marching ants disappeared from my copied range.

I'd try changing the order of these statements:

ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveSheet.Paste

So that you paste first, then add the page break.


I have a consolidation routine that will, if the user chooses, consolidate the output of all the
sheets in our generated report onto one sheet by appending them one after the other with the
ActiveSheet.Paste method. It has been working fine with no problems until one customer generated a
LOT of reports which means a lot of worksheets in the book and a lot of calls to cut and paste them
all onto one sheet. Through trial and error I found that my machine can handle 90 reports (90
worksheets pasted into one sheet via a loop) before the error occurs. The customer was generating 92
reports (but I do not know at what point the error occurred for him).

The runtime error is:
Method 'Paste' of object '_Worksheet' failed

On a few occasions the same .paste call generated this error first:
No more new fonts may be applied in this workbook.

I'm guessing it is related to available resources somehow but exactly what I have no idea.
Monitoring the system memory shows no increase as the program runs. After 50 or so iterations I do
notice a progressive slowdown beginning.

Here is the code that does the consolidation. The error occurs on the ActiveSheet.Paste call.

Robb
========================================================

Private Sub ConsolidateSheets(SourceWB As Workbook)
'CONSOLIDATES ALL REPORT SHEETS OF PASSED WORKBOOK ONTO ONE SHEET
Dim I As Integer
Dim R As Integer
Dim C As Integer
Dim CurrentRow As Integer
Dim MasterSheet As Worksheet
Dim FoundMasterSheet As Boolean

FoundMasterSheet = False
For I = 1 To SourceWB.Sheets.Count 'LOOP THROUGH ALL SHEETS OF PASSED WORKBOOK
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then 'FIND FIRST REPORT SHEET
If FoundMasterSheet = False Then
FoundMasterSheet = True
Set MasterSheet = SourceWB.Sheets(I)
Set SPC_RS = SourceWB.Sheets(I)
MasterSheet.PageSetup.Zoom = False
MasterSheet.PageSetup.FitToPagesWide = 1
MasterSheet.PageSetup.Zoom = 80
Else 'FIRST REPORT SHEET ALREADY FOUND. NOW COPY TO IT
CurrentRow = GetLastUsedRowCol(MasterSheet, "ROW") + 2 'GET ROW TO COPY TO
R = GetLastUsedRowCol(SourceWB.Sheets(I), "ROW") 'GET RANGE OF CELLS TO COPY
C = GetLastUsedRowCol(SourceWB.Sheets(I), "COL")
SourceWB.Sheets(I).Activate 'SWITCH TO REPORT SHEET TO COPY FROM
SourceWB.Sheets(I).Range(GetRangeString(1, 1, C, R)).Select 'SELECT DATA
Selection.Copy 'COPY DATA
MasterSheet.Activate 'SWITCH TO REPORT SHEET TO COPY TO
MasterSheet.Cells(CurrentRow, 1).Select 'SET LOCATION TO PASTE TO
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell 'SET A PAGE BREAK
ActiveSheet.Paste 'PASTE DATA
End If
End If
Next I

ActiveSheet.PageSetup.FitToPagesWide = 1

On Error Resume Next 'DELETE SHEETS THAT WERE COPIED
Application.DisplayAlerts = False
For I = SourceWB.Sheets.Count To 1 Step -1
If Right(SourceWB.Sheets(I).Name, 8) = "{Report}" Then
If SourceWB.Sheets(I).Name <> MasterSheet.Name Then
SourceWB.Sheets(I).Delete
End If
End If
Next I
Application.DisplayAlerts = True
On Error GoTo 0

MasterSheet.Cells(1, 1).Select 'SELECT CELL A,1 (AESTHETIC REASONS ONLY)

End Sub

Public Function GetLastUsedRowCol(WS As Worksheet, RowOrCol As String) As Variant
'RETURNS THE NUMBER OF THE LAST ROW IN THE SPECIFIED WORKSHEET'S USEDRANGE
Dim CellWasEmpty As Boolean

CellWasEmpty = (WS.Cells(1, 1) = "") 'CELL(1,1) IS EMPTY

If CellWasEmpty Then 'IF CELL IS EMPTY, THEN TEMP FILL IT
WS.Cells(1, 1) = "."
End If

Select Case UCase(RowOrCol)
Case "ROW": GetLastUsedRowCol = WS.UsedRange.Rows.Count
Case "COL": GetLastUsedRowCol = WS.UsedRange.Columns.Count
Case Else: MsgBox "Invalid value [" & RowOrCol & "] passed." & vbCrLf & _
"Module: modTarus" & vbCrLf & _
"Function: GetLastUsedRowCol", vbCritical, "Program Error"
GetLastUsedRowCol = 0
End Select

If CellWasEmpty Then WS.Cells(1, 1).Clear 'IF CELL WAS ORIGINALLY EMPTY, THEN EMPTY IT AGAIN

End Function

========================================================
Click to expand...
Click to expand...
 
Back
Top