Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
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(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 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 +------------------------------------------------------------------- -- windso ----------------------------------------------------------------------- windsor's Profile: http://www.excelforum.com/member.php...fo&userid=2784 View this thread: http://www.excelforum.com/showthread.php?threadid=47358 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
Hi windsor
I have not test your code but look here for another example http://www.rondebruin.nl/copy5.htm -- Regards Ron de Bruin http://www.rondebruin.nl "windsor" wrote in message ... Hello Everyone, First I would like to thank anyone in advance who is willing to tackle this problem with me. New guy here. I've been working on this Macro that splits up my data from a master sheet and splits it into many different tabs and names them according to the account number which is in the far most right coloumn. It groups all of the specific accounts activity in the one tab. The problem I have is after I copy about 15 sheets or so it brings up 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. 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(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 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... Dejan +-------------------------------------------------------------------+ |Filename: tEST.zip | |Download: http://www.excelforum.com/attachment.php?postid=3883 | +-------------------------------------------------------------------+ -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
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 -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
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) -- Regards Ron de Bruin http://www.rondebruin.nl "windsor" wrote in message ... 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 -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
I think I misunderstood you
Let me know -- Regards Ron de Bruin http://www.rondebruin.nl "Ron de Bruin" wrote in message ... 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) -- Regards Ron de Bruin http://www.rondebruin.nl "windsor" wrote in message ... 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 -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
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 -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
PasteSpecial method of Range class failed
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 -- Regards Ron de Bruin http://www.rondebruin.nl "windsor" wrote in message ... 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 -- windsor ------------------------------------------------------------------------ windsor's Profile: http://www.excelforum.com/member.php...o&userid=27849 View this thread: http://www.excelforum.com/showthread...hreadid=473581 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Autofill method of range class failed | Excel Discussion (Misc queries) | |||
Select method of range class failed | Excel Programming | |||
Delete method of Range class failed - HELP!!! | Excel Programming | |||
select method of range class failed | Excel Programming | |||
Run-time error '1004' PasteSpecial Method of Range Class Failed | Excel Programming |