MACRO ERROR

[Dejan]

I have a larga database of information about 2000 lines, I have a macro that
divides the information into seperate tabs based on the account number found
in the left-most coloumn. The problem happens after it copies about 15 sheet
or so I get this
error:

Excel cannot complete this taks with available resources. Choose less 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.

************************************
HERE IS THE MACRO

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.Cells.EntireColumn.AutoFit
.AutoFilter
Application.CutCopyMode = False
Printing
ClearTheClipBoard
ClearClipboard
End With
Resume
SheetExists:
Next myCell

End Sub

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


Sub NoCopyAndPaste()
'Instead of:
Sheet1.Range("A1:A200").Copy
Sheet2.Range("B1").PasteSpecial
Application.CutCopyMode = False 'Clear Clipboard
'Use:
'By-passes the Clipboard
Sheet1.Range("A1:A200").Copy Destination:=Sheet2.Range("B1")
'Or, if only values are needed:
Sheet2.Range("B1:B200").Value = Sheet1.Range("A1:A200").Value
'Or, if only formulae are needed:
Sheet2.Range("B1:B200").Formula = Sheet1.Range("A1:A200").Formula
'See also FormulaArray and FormulaR1C1 etc
'Instead of:
Sheet1.Range("A1:A200").Copy
Sheet1.Range("A1:A200").PasteSpecial xlPasteValues
Application.CutCopyMode = False 'Clear Clipboard
'Use:
Sheet1.Range("A1:A200") = Sheet1.Range("A1:A200").Value
End Sub

Sub PasteSpecialValues() 'assign macro to Ctrl+SHIFT+V
On Error Resume Next
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
If Err.Number = 1004 Then
MsgBox "Can't Paste Special Values from Empty Clipboard" _
& Chr(10) & "or dimension of multiple cells does not" _
& " match clipboard" _
& Chr(10) & Err.Number & " " & Err.Description
ElseIf Err.Number <> 0 Then
MsgBox Err.Number & " " & Err.Description
End If
Application.CutCopyMode = False 'Clear Clipboard
End Sub

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

'
Cells.Select
With Selection.Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
Range("A1").Select
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 = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub

Sub ClearTheClipBoard()

Dim oClipClear As CommandBarButton
On Error Resume Next
Set oClipClear = Application.CommandBars("clipboard") _
.FindControl(ID:=3634)
If Not oClipClear Is Nothing Then
If oClipClear.Enabled Then oClipClear.Execute
End If
On Error GoTo 0

End Sub

****************************************************

What am I doing wrong?

Thanks for you input.

btw: I have a 512 MB RAM, 2.0 GHZ Processor, Only Excel Open, I closed down
all other prongrams.

Dejan