PasteSpecial method of Range class failed

[windsor]

Hello Everyone,

First I would like to thank anyone in advance who is willing to tackl
this problem with me.

New guy here. I've been working on this Macro that splits up my dat
from a master sheet and splits it into many different tabs and name
them according to the account number which is in the far most righ
coloumn. It groups all of the specific accounts activity in the on
tab.

The problem I have is after I copy about 15 sheets or so it brings u
this error:

Excel cannot complete this taks with available resources. Choose les
data
or close other applications.

I push OK

then it says:

Run-Time error '1004':

PasteSpecial method of Range class failed

I push Debug

it highlights

mySht.Range("A1").PasteSpecial xlPasteValues

If i push End

it says:

The picture is too large and will be truncated.

I push OK

and it comes up two more times and the book closes.


vba code


Option Explicit

Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Sub ExportDatabaseToSeparateFiles()
'Export is based on the value in the desired column

Dim myCell As Range
Dim mySht As Worksheet
Dim myName As String
Dim myArea As Range
Dim myShtName As String
Dim KeyCol As Integer

myShtName = ActiveSheet.Name
KeyCol = InputBox("What column # within database to use as key?")

Set myArea = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1
0).Cells

Set myArea = myArea.Resize(myArea.Rows.Count - 1, 1)

For Each myCell In myArea
On Error GoTo NoSheet
myName = Worksheets(myCell.Value).Name
GoTo SheetExists:
NoSheet:
Set mySht = Worksheets.Add(Before:=Worksheets(1))
mySht.Name = myCell.Value
With myCell.CurrentRegion
.AutoFilter Field:=KeyCol, Criteria1:=myCell.Value
myCell.Parent.Cells.SpecialCells(xlCellTypeVisible).Copy
mySht.Range("A1").PasteSpecial xlPasteValues
mySht.Range("A1").PasteSpecial xlPasteFormats
mySht.Cells.EntireColumn.AutoFit
.AutoFilter
ClearCipboard
Application.CutCopyMode = False

End With
Resume
SheetExists:
Next myCell

End Sub

Sub ClearClipboard()
OpenClipboard Application.hwnd
EmptyClipboard
CloseClipboard
End Sub

end vba

Thanks so much for your help...

Deja

+-------------------------------------------------------------------
|Filename: tEST.zip
|Download: http://www.excelforum.com/attachment.php?postid=3883
+-------------------------------------------------------------------

 

[Ron de Bruin]

Hi windsor

I have not test your code but look here for another example
http://www.rondebruin.nl/copy5.htm

 

[windsor]

Hi Ron,

Thank you for this awesome macro! Very fast much better than mine.
One question I can't seem to get it to copy the subtotal to each of
sheets the subtotal is at the bottom of the table and is preceeded by a
blank line.

Thanks for your help again.

Dejan

 

[Ron de Bruin]

Hi Dejan

Add one dim line

Dim Lrow2 As Long

and before the columns.autofit line
Note I asume that all cell in column A have data, maube you must chnage the A to another column ?

Lrow2 = .Cells(Rows.Count, "A").End(xlUp).Row
.Rows(Lrow2).Copy WSNew.Range("A" & WSNew.UsedRange.Rows.Count + 2)

 

[Ron de Bruin]

I think I misunderstood you

Let me know

--
Regards Ron de Bruin
http://www.rondebruin.nl

Hi Dejan

Add one dim line

Dim Lrow2 As Long

and before the columns.autofit line
Note I asume that all cell in column A have data, maube you must chnage the A to another column ?

Lrow2 = .Cells(Rows.Count, "A").End(xlUp).Row
.Rows(Lrow2).Copy WSNew.Range("A" & WSNew.UsedRange.Rows.Count + 2)

 

[windsor]

Hello Ron,

No, you gave me exactly what I needed. Thank's so much. I've been
working on this macro for quite a long time, yours is so much better,
i've incorporated your lines so that once it copies all the value it
creates a total for each coloumn that needs totalling. This is very
nice, just took me a little while to figure out which formual to use in
order to get a total to come up instead of the #REF!

My second question was is there a simpler way of getting the page print
formated other than the way that I have it done here.

Thanks.


Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim Lrow2 As Long



Set ws1 = Sheets("Sheet1") '<<< Change

'Set ws1 = ActiveCell.CurrentRegion.Columns(KeyCol).Offset(1,
0).Cells

'Set ws1 = myArea.Resize(myArea.Rows.Count - 1, 1)
'Tip : Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'or a fixed range like Range("A1:H1200")
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

With Application
CalcMode = .Calculation
..Calculation = xlCalculationManual
..ScreenUpdating = False
End With

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'This example filter on the first column in the range (change
this if needed)
'You see that the last two columns of the worksheet are used to
make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use
the columns)

Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
..Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
..Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
Printing
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & "
manually"
Err.CLEAR
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Lrow2 = .Cells(Rows.Count, "a").End(xlUp).Row
..Rows(Lrow2).Copy WSNew.Range("a" &
WSNew.UsedRange.Rows.Count + 2)
Next
..Columns("IU:IV").CLEAR
End With

With Application
..ScreenUpdating = True
..Calculation = CalcMode
End With
End Sub

Sub Printing()
'
' Printing Macro
' Macro recorded 10/3/2005 by Dejan Lukic
'

'
With ActiveSheet.PageSetup
..PrintTitleRows = "$1:$1"
..PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
..LeftHeader = ""
..CenterHeader = ""
..RightHeader = ""
..LeftFooter = "&F"
..CenterFooter = "&A"
..RightFooter = "&P OF &N"
..LeftMargin = Application.InchesToPoints(0.75)
..RightMargin = Application.InchesToPoints(0.75)
..TopMargin = Application.InchesToPoints(1)
..BottomMargin = Application.InchesToPoints(1)
..HeaderMargin = Application.InchesToPoints(0.5)
..FooterMargin = Application.InchesToPoints(0.5)
..PrintHeadings = False
..PrintGridlines = False
..PrintComments = xlPrintNoComments
..PrintQuality = 600
..CenterHorizontally = True
..CenterVertically = False
..Orientation = xlLandscape
..Draft = False
..PaperSize = xlPaperLetter
..FirstPageNumber = xlAutomatic
..Order = xlDownThenOver
..BlackAndWhite = False
..Zoom = False
..FitToPagesWide = 1
..FitToPagesTall = False
..PrintErrors = xlPrintErrorsDisplayed
End With
End Sub

 

[Ron de Bruin]

Hi Windsor

My second question was is there a simpler way of getting the page print
formated other than the way that I have it done here.

Excel is not good at this and very slow
But you can delete a lot of the lines if you want

A faster way is to use a old Excel4 macro
John Green posted this if you want to read it

PageSetup in VBA has always been a painfully slow process. If you can't avoid having
to set these parameters, you can use the Excel 4 macro function, PAGE.SETUP to carry
out most of the PageSetup operations much more quickly. The following two macros are
almost equivalent, and should give you the clues you need to start using PAGE.SETUP.
You can download a full description of all the Excel 4 macro functions from
Microsoft's web site:

Sub PS()
ActiveSheet.DisplayPageBreaks = False
With ActiveSheet.PageSetup
.LeftHeader = "My Company"
.CenterHeader = ""
.RightHeader = "&D / &T"
.LeftFooter = "Highly Confidential and Proprietary"
.CenterFooter = ""
.RightFooter = "Finance"
.LeftMargin = Application.InchesToPoints(0.54)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.36)
.HeaderMargin = Application.InchesToPoints(0.22)
.FooterMargin = Application.InchesToPoints(0.17)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
' .PrintQuality = 600 ' does not work with all the printers
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End Sub

Sub PS4()
head = """&LMy Company&R&D / &T"""
foot = """&LHighly Confidential and Proprietary&RFinance"""
pLeft = 0.54
pRight = 0.3
Top = 0.4
bot = 0.36
head_margin = 0.22
foot_margin = 0.17
hdng = False
grid = False
notes = False
quality = ""
h_cntr = False
v_cntr = False
orient = 2
Draft = False
paper_size = 1
pg_num = """Auto"""
pg_order = 1
bw_cells = False
pscale = True
pSetUp = "PAGE.SETUP(" & head & "," & foot & "," & pLeft & "," & pRight & ","
pSetUp = pSetUp & Top & "," & bot & "," & hdng & "," & grid & "," & h_cntr & ","
pSetUp = pSetUp & v_cntr & "," & orient & "," & paper_size & "," & pscale & ","
pSetUp = pSetUp & pg_num & "," & pg_order & "," & bw_cells & "," & quality & ","
pSetUp = pSetUp & head_margin & "," & foot_margin & "," & notes & "," & Draft & ")"

Application.ExecuteExcel4Macro pSetUp
End Sub

John Green (Excel MVP)
Sydney
Australia