Hello,
Sorry to bother again, did as you told, it did run a little longer but
still the same problem....
So i guess I'm back to square one then.
I really appreciate you tyring.
Dejan
"Bernie Deitrick" wrote:
Dejan,
Copy everything below into an otherwise blank codemodule.
HTH,
Bernie
MS Excel MVP
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(Befo=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
Application.CutCopyMode = False
ClearClipboard
End With
Resume
SheetExists:
Next myCell
End Sub
Sub ClearClipboard()
OpenClipboard Application.hwnd
EmptyClipboard
CloseClipboard
End Sub
"Dejan" wrote in message
...
Hello Bernie,
I put the new code in and this is the error I get now, I think I put it in
the right place tried to put in a few places but it doesn't want to work.
Also the ClearClipboard is not defined anywhere.
Thanks Bernie
Compile error:
Only comments may appear after End Sub, End Function, or end Property
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
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
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(Befo=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
Application.CutCopyMode = False
ClearClipboard
End With
Resume
SheetExists:
Next myCell
End Sub
"Bernie Deitrick" wrote:
Dejan,
Sounds like a memory-leak problem. I haven't sued very large data sets with this macro: try
adding
Application.CutCopyMode = False
just after the line:
..AutoFilter
Also, try this. Put this at the top of your module (just below the option explicit statement)
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
And put this somewhere in your module:
Sub ClearClipboard()
OpenClipboard Application.hwnd
EmptyClipboard
CloseClipboard
End Sub
Then put the line
ClearClipboard
within your loop (after the .AutoFilter line) as well.
HTH,
Bernie
MS Excel MVP
"Dejan" wrote in message
...
Hello Again Bernie,
Thanks alot for your help again, I figured that out after some trial and
error.
Now I have a nother problem, 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.
What am I doing wrong now?
Thanks for you input, once again.
btw: I have a 512 MB RAM, 2.0 GHZ Processor, Only Excel Open, I closed down
all other prongrams.
Dejan
"Bernie Deitrick" wrote:
Dejan,
Your key values are numbers, so change
myName = Worksheets(myCell.Value).Name
to
myName = Worksheets(CStr(myCell.Value)).Name
Worksheets can take either a number or a string - if it uses a number, it looks for that
number
sheet (the 10321st sheet) rather than one with that sheet name.
Sorry about that - I wrote the base code to work with alpha-numeric keys.
HTH,
Bernie
MS Excel MVP
"Dejan" wrote in message
...
Hello Bernie!
Sorry just one more problem, I was running the Macro on a actual sheet and I
got a this error:
Run-time error '1004':
Cannot rename a sheet to the same name as another sheet, a
referenced object library or workbook refreenced by Visual Basic.
It creates the first sheet fine, when it gets to the second customer that is
when it screws up this is the macro:
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(Befo=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
End With
Resume
SheetExists:
Next myCell
End Sub
Here are some of the values from the first few coloumns:
A B C D E
ACCOUNT INVOICE INV DATE STR FBY
10321 5173728 8/9/2005 5 59
10321 5175563 8/4/2005 5 51
10321 5175736 8/11/2005 5 69
10321 5175804 8/5/2005 5 59
10321 5176748 8/11/2005 5 59
10321 5176751 8/11/2005 5 59
10321 5178686 8/19/2005 5 69
|