Loop Problem - Copy Specific Rows to named sheets with Loop

[danielphayward]

I'm using Excel 2013 on Windows 7 and while I'm not getting errors, it's also not doing what I want it to, its doing nothing.

What I'm trying to do is go through a list in Column Y and have each row with the same value in Column J copied to a new sheet by the same name.


I can manually copy the code down a bunch of times but the loop function would work perfectly for this...if I could get it to work at all.

Sub CopytoNewSheets()
'
' Macro2 Macro
'


'


    Sheets("Input").Select
    'I had RowCount as integer but I kept getting Overflow error 6
    Dim RowCount As Long
    Do Until RowCount = 0
        RowCount = Sheets("Open Items").Range("Y2").End(xlDown).Row
        
    'If I exclude the Do Until and Loop function at the end, this code does it what I want it to, maybe its clumsy but I haven't been writing VBA long enough to know. 
    'Sorts !Input by First Value in Column Y
    ActiveSheet.Range("$A$1:$J$3000").AutoFilter Field:=10, Criteria1:=Range("Y2")
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    'Copies Data to new worksheet
    Selection.Copy
    Sheets(Range("Y2").Value).Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("A1").Select
    'Goes back to Open Item worksheet
    Sheets("Open Items").Select
    Application.CutCopyMode = False
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A1").Select
    
    Sheets("Open Items").Select
    ActiveSheet.ShowAllData
    ActiveWorkbook.Worksheets("Open Items").Sort.SortFields.Add KEY:=Range("A1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
        
    
    With ActiveWorkbook.Worksheets("Open Items").Sort
        .SetRange Range("A:J")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlAscending
        .Apply
    End With
    
    
    Loop


    
End Sub

If you can help I'd greatly appreciate it.

 

[danielphayward]

No column Y doesn't get picked up with the Range(Selection, Selection.End(xlToRight)).Select part of the code. It should only select A:J. I could make sure by saying that explicitly in the code...but it doesn't seem like that is where the problem is.

 

[mole999]

i'm begining to understand what is happening

what I'm thinking

select A to Y in one move

sort on Y

then release the sort

select the first value and identify how many rows it goes for

check if the sheet exists if it does then copy A to J to it, if not create sheet, copy the data across, return and delete the used rows

then repeat until Y2 is empty

does that sound about right

 

[danielphayward]

So I've tried stepping through. Most everything happens except that when the do while/do until/loop just isn't working for me. I don't know if I have the While/Until/When in the wrong place but it all works except that I get the Out of Range Error. Again, here's the most updated code.

Sub CopytoNewSheets()'
' Macro2 Macro
'


'


    Sheets("Open Items").Select
    'I had RowCount as integer but I kept getting Overflow error 6
    
    Dim RowCount As Integer
    RowCount = Application.WorksheetFunction.CountA(Range("Y2:Y2000"))
    Do While RowCount > 0
        
    'If I exclude the Do Until and Loop function at the end, this code does it what I want it to, maybe its clumsy but I haven't been writing VBA long enough to know.
    'Sorts !Input by First Value in Column Y
    ActiveSheet.Range("$A$1:$J$3000").AutoFilter Field:=10, Criteria1:=Range("Y2")
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    'Copies Data to new worksheet
    Selection.Copy
    Sheets(Range("Y2").Value).Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("A1").Select
    'Goes back to Open Item worksheet
    Sheets("Open Items").Select
    Application.CutCopyMode = False
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
    Columns("A:J").Select
    ActiveSheet.ShowAllData
    ActiveWorkbook.Worksheets("Open Items").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Open Items").Sort.SortFields.Add KEY:=Range("A1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Open Items").Sort
        .SetRange Range("A1:J3000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
    
    Loop

 

[danielphayward]

The out of range happens on the Sheets(Range("Y2").Value).Select line

 

[danielphayward]

You've got it mostly. I want it to autofilter on Y2, then copy A:J. Sorry I didn't see this earlier, I think I didn't realize our thread had gone onto another page.

Another difficulty for me is when I run the code through it give me that Runtime Error 9, subscript out of range because the sheet doesn't exist with no name. But when I run the code a second time without changing any data, it doesn't error out and as I step through, I can see that it skips over everything because there isn't any data in Y2. Is the RowCount on the wrong side of the Do statement?

 

[danielphayward]

Okay I've been working on this for awhile and the problem is in the following

 RowCount = Application.WorksheetFunction.CountA(Range("Y1:Y2000"))

The reason the problem is here is because I thought that this was dynamic, that is, it changed every time the loop ran but it doesn't. When using the step through and having the problem, I saw that RowCount was set at 3, even though there wasn't anything in Column Y.

 

[mole999]

before that line

Dim LR As Long
Sheets("open items").Select
LR = Sheets("open items").Range("Y65536").End(xlUp).Row

RowCount = Application.WorksheetFunction.CountA(Range("Y1:Y" & LR))

 

[danielphayward]

I can see why that would work but here's how I ended up doing it.

Sub CopytoNewSheets()'
' Macro2 Macro
'


'
 Application.ScreenUpdating = False
    Sheets("Open Items").Select
    
    Dim RowCount As Integer
    Dim i As Integer


    RowCount = Application.WorksheetFunction.CountA(Range("Y1:Y2000"))
   i = i + 1


    Do While RowCount > 0
         RowCount = Application.WorksheetFunction.CountA(Range("Y1:Y2000")) - i
         
    'Sorts !Input by First Value in Column Y
    ActiveSheet.Range("$A$1:$J$3000").AutoFilter Field:=10, Criteria1:=Range("Y2")
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    'Copies Data to new worksheet
    Selection.Copy
    Sheets(Range("Y2").Value).Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
        Range("A1").Select
    'Goes back to Open Item worksheet
    Sheets("Open Items").Select
    Rows("2:2").Select
    Selection.Delete Shift:=xlUp
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
    Columns("A:J").Select
    ActiveSheet.ShowAllData
    ActiveWorkbook.Worksheets("Open Items").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Open Items").Sort.SortFields.Add KEY:=Range("J1") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Open Items").Sort
        .SetRange Range("A1:J3000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    
    
    Loop


 Application.ScreenUpdating = True
End Sub