Automatically Splitting Rows into Different Worksheets - Run-time error '1004' PasteSpecial method of Range class failed.

[dougmarkham]

Hi folks,

I have been tasked with splitting a master worksheet into multiple worksheets i.e., splitting the data by values in a selected column.
For instance: if the selected column contained different values for 'sales person', the task would be to split sales data for each 'sales person' into a new worksheet (within the same workbook) named after the 'sales person'.

I found some VBA code for splitting into multiple workbooks and modified the code to instead split the data into multiple worksheets. Here is the code:

[COLOR=#0000cd]Sub[/COLOR] Split()


[COLOR=#0000cd]Dim[/COLOR] example [COLOR=#0000cd]As String[/COLOR]
[COLOR=#0000cd]Dim [/COLOR]data [COLOR=#0000cd]As String[/COLOR]


example = ActiveWorkbook.Name
data = ActiveSheet.Name


vColumn = InputBox("Please indicate which column (i.e. A, B, C, …), you would like to split by", "Column selection")


Columns(vColumn).Copy
Sheets.Add
ActiveSheet.Name = "_Summary"
Range("A1").PasteSpecial
Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes


vCounter = Range("A" & Rows.Count).End(xlUp).Row


[COLOR=#0000cd]For[/COLOR] i = 2 [COLOR=#0000cd]To[/COLOR] vCounter
    vfilter = Sheets("_Summary").Cells(i, 1)
    Sheets(data).Activate
    ActiveSheet.Columns.AutoFilter field:=Columns(vColumn).Column, Criteria1:=vfilter
    Cells.Copy
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
   [COLOR=#b22222] Range("A1").PasteSpecial[/COLOR]
   [COLOR=#0000cd] If[/COLOR] vfilter <> "" [COLOR=#0000cd]Then[/COLOR]
        ActiveSheet.Name = vfilter
[COLOR=#0000cd]        Else[/COLOR]
        Application.DisplayAlerts = [COLOR=#0000cd]False[/COLOR]
        ActiveWindow.SelectedSheets.Delete
        Application.DisplayAlerts = [COLOR=#0000cd]True[/COLOR]
[COLOR=#0000cd]    End If[/COLOR]
    'Activate Workbook
    Workbooks(example).Activate
[COLOR=#0000cd]Next i[/COLOR]
Sheets("_Summary").Delete


[COLOR=#0000cd]End Sub[/COLOR]

The idea is that you select the column (e.g., Col C) containing the variable that you're extracting by, then excel selects by the first variable in 'Column C' it comes to, extracts the rows of data with corresponding to that variable, then loops to the next variable down in 'Column C'. Then excel repeats till all the variables in that column have had the data extract completed. So if column C is selected and there are 20 sales persons, it cycles through each sales person.

Using F8 to check each stage in testing, the error occurs after Cells.Copy: specifically when excel tries to paste into the new sheet i.e.,

    Cells.Copy
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    [COLOR=#ff0000]Range("A1").PasteSpecial[/COLOR]

After pasting, I get the following error messages:
1) Microsoft excel error message - Excel cannot complete this task with available resources. Choose less data or close other applications.
2) VBA error message - Run-time error '1004' PasteSpecial method of Range class failed.

I closed all other applications and shortened the data set but still get the error message.

Now, I looked into this using Google search and one fellow who had a similar experience said:

I don't know if this is any help, but I had a similar problem and this is the note I made to myself relative to that:

Note, doing a WorkBooks…Add after a .Copy apparently clears out the paste buffer,
i.e. the copied data is lost, so attempting a PasteSpecial fails since the buffer is now empty.
Solution: do the .Copy after the .Add
When doing a .Copy / .PasteSpecial, avoid doing anything in between.

Would anybody be willing to help me fix this code if possible, or will anybody suggest an alternative?

Kind regards,

Doug.

 

[MARK858]

Johnny C there is no need to Select the cells or activating the Sheet and PasteSpecial is fine by itself (it just does a PasteAll).

Having stated that then there is no need to PasteSpecial unless you are only copying Values/formatting/formulas etc. or combinations of these rather than a PasteAll as you can use its destination directly.

Sub testcode()
Dim wksSourceSheet As Worksheet, wksTargetSheet As Worksheet
    Set wksSourceSheet = ActiveSheet
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    Set wksTargetSheet = ActiveSheet
    wksSourceSheet.Cells.Copy wksTargetSheet.Range("A1")
End Sub

 

[MARK858]

@dougmarkham, try the code below. Beware I haven't tested it so expect errors or it to be referring to the wrong sheet somewhere.

Sub SplitNmsm()

Dim nmsm As Workbook, vColumn As String
Dim nmss As Worksheet, DestSht As Worksheet
Dim vCounter As Long, i As Long, vfilter

Set nmsm = ActiveWorkbook
Set nmss = ActiveSheet


vColumn = InputBox("Please indicate which column (i.e. A, B, C, Â…), you would like to split by", "Column selection")

Sheets.Add
ActiveSheet.Name = "_Summary"
Set DestSht = ActiveSheet
nmss.Columns(vColumn).Copy DestSht.Range("A1")
DestSht.Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes


vCounter = DestSht.Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To vCounter
    vfilter = DestSht.Cells(i, 1)
    nmss.Columns.AutoFilter field:=nmss.Columns(vColumn).Column, Criteria1:=vfilter
    ' Please note that the way you define the field could cause problems with your filter
    ' range doesn't always start in column A
    Workbooks.Add
    nmss.Cells.SpecialCells(12).Copy Range("A1")
    If vfilter <> "" Then
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Non Moving Stock\" & vfilter
    Else
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Non Moving Stock\_Empty"
    
    End If
    ActiveWorkbook.Close
Next i


DestSht.Delete


End Sub

 

[Youngdand]

This is the code i use. the only time i get an issue, is if the value in the chosen column is too large for a sheet name.

Sub Split_to_sheets()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Long
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim IB2 As Long
IB2 = InputBox("Enter column number to split by", "Choose Column Number", 1)
vcol = IB2
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:C1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

 

[dougmarkham]

Try this:-

    Set wksSourceSheet = Activesheet
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    Set wksTargetSheet = Activesheet
    wksSourceSheet.Activate
    Cells.Select
    Selection.Copy
    wksTargetSheet.Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= False
    Application.CutCopyMode = False

Hi Johnny,

Thanks for all your replies---I think you and Mark858 have got me over the line on this one.
I had 2 days off and then tried your suggested fixes and those by MARK858. The same error messages (Run-time error '1004') come after trying to paste source to target.

I think it's trying to copy/paste more than 100,000 rows (most of which are empty), and giving itself too much to do, no matter which paste option is used.
I was thinking that even if one could copy/paste only cells with data, a simpler solution would be to set a large but finite range to copy/paste which would suit most if not all workbooks that might come my way.

I tried this copy/paste line that encapsulates this particular table range and it worked...

Sub Split()


Dim example As String
Dim data As String


example = ActiveWorkbook.Name
data = ActiveSheet.Name


vColumn = InputBox("Please indicate which column (i.e. A, B, C, …), you would like to split by", "Column selection")


Columns(vColumn).Copy
Sheets.Add
ActiveSheet.Name = "_Summary"
Range("A1").PasteSpecial
Columns("A").RemoveDuplicates Columns:=1, Header:=xlYes


vCounter = Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To vCounter
    vfilter = Sheets("_Summary").Cells(i, 1)
    Worksheets("data").Activate
    ActiveSheet.Columns.AutoFilter field:=Columns(vColumn).Column, Criteria1:=vfilter
    Dim wksSourceSheet, wksTargetSheet
    Set wksSourceSheet = ActiveSheet
    ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
    Set wksTargetSheet = ActiveSheet
    wksSourceSheet.Activate
[B][COLOR=#008000]    wksSourceSheet.Range("A1:AQ5000").Copy wksTargetSheet.Range("A1:AQ5000")[/COLOR][/B]
    wksTargetSheet.Activate
    If vfilter <> "" Then
        ActiveSheet.Name = vfilter
        Else
        Application.DisplayAlerts = False
        ActiveWindow.SelectedSheets.Delete
        Application.DisplayAlerts = True
    End If
    'Activate Workbook
    Workbooks(example).Activate
Next i
Sheets("_Summary").Delete
End Sub

Unless there is a line of code that can establish the range of the table without being specific, won't Run-time error '1004': PasteSpecial method of Range class failed always happen due to it trying to copy/paste too big a range?

This has been a useful learning experience! Thanks for helping me with this!

Kind regards,

Doug.

 

[MARK858]

There are various methods of getting the range but I won't be posting anything until I get in tonight.

 

[MARK858]

A few options (amongst many) of getting the range depending on exactly what your data looks like...

wksSourceSheet.UsedRange.Copy wksTargetSheet.Range("A1")

or

wksSourceSheet.Range("A1").CurrentRegion.Copy wksTargetSheet.Range("A1")

or

    Dim lc As Long, lr As Long
    With wksSourceSheet
        lc = .Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious, False).Column
        lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious, False).Row
        .Range(.Cells(1, "A"), .Cells(lr, lc)).Copy wksTargetSheet.Range("A1")
    End With

or

    Dim lr As Long
    With wksSourceSheet
        lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious, False).Row
        .Range(.Cells(1, "A"), .Cells(lr, "AQ")).Copy wksTargetSheet.Range("A1")
    End With

 

[Johnny C]

Another option might be to select all the data, and convert it to a table - select it all, then Insert>Table and rename it to something meaningful e.g. tblCopyData

Then you can use

wksSourceSheet.ListObjects("tblCopyData").Range.Copy wksTargetSheet.Range("A1")

or if you need to specify the same sized range

wksSourceSheet.ListObjects("tblCopyData").Range.Copy wksTargetSheet.Range(Cells(1,1), Cells(wksSourceSheet.ListObjects("tblCopyData").Range.Rows.Count, wksSourceSheet.ListObjects("tblCopyData").Range.Columns.Count))

The size of the table adjusts automatically when you add (or delete) data from it, which makes life a lot easier with variable amounts of data. If you have any formulae in there it also expands them up or down to fill all cells.

I use tables whenever it's a table of variable size. More for lookup tables than large data tables but Excel might deal with it better as a table if it's large.