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.

 

[mole999]

in this sequence (in my incomplete testing)
Do Until RowCount = 0
RowCount = Sheets("Open Items").Range("Y2").End(xlDown).Row

rowcount starts at zero and doesn't get populated so the sub exits

swapped to

RowCount = Sheets("Open Items").Range("Y2").End(xlDown).Row
Do Until RowCount = 0

I get Rowcount as 1048576

yet we are constrained to
("$A$1:$J$3000")

If we know the width of the data at this point and it dosn't change then

Range(Selection, Selection.End(xlToRight)).Select
can be superflous
and maybe
ActiveSheet.Range("$A$1:$J$3000").AutoFilter Field:=10, Criteria1:=Range("Y2") could become
ActiveSheet.Range("$A$1:$Y$3000").AutoFilter Field:=10, Criteria1:=Range("Y2")

 

[danielphayward]

So I've gotten it to work that it copies to the separate sheets with all the data, but now it ends with an Error: 9, subscript out of range and it stops the line "Sheets(Range("Y2").Value).Select" because no sheet exists, but shouldn't it see that there aren't any values in Column Y and stop the loop? Here's my 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 Long
    RowCount = Sheets("Open Items").Range("Y2").Row
    Do Until 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
    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
[\ Code]

 

[mole999]

if the sheet doesn't exist then it can't use that as a reference to work from. It sometimes is an issue when you use active sheet as swapping back and forth you must ensure excel has the right access to the right sheet

 

[danielphayward]

So, when it loops through the first couple of times (when there is data in the Y2) it works fine. I was hoping to have it stop looping when there isn't any data left in that column? Am I coming at this from the wrong angle? What's a better way to have the code run so that it doesn't error out?

 

[mole999]

I see you still have A:J yet we are looking for values in Y, are they all being removed as expected and then it errors out ?

 

[danielphayward]

So what's happening is A:J visible data is being copied to named sheets for value in Y2, then 2:2 is being deleted (and the sheet is then shifted up). The loop is then supposed to be check whether there are values in Y2:Y2000, if there are loop again, if not exit out.

Again, this is my first real foray into writing actual VBA, up to this point I've pretty much recorded macros and deleted stuff that didn't need to be recorded and sometimes I've copied stuff I've found on this and other websites, when it suits me. I think the problem has to do with the loop not checking Rowcount at the right time. My code now is below.

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

    '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
        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 Until RowCount = 0

End Sub

 

[mole999]

it may be just me, the last code dosn't seem to show the sheet that is taking the data

i'm going to try and build something i can test with

when you step through what else gets selected with Range(Selection, Selection.End(xlToRight)).Select does that pick up Y col

 

[danielphayward]

Sorry, I was trying something with that last code. this is actually what I'm using.

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 Until 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
    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

 

[mole999]

If you step through your VBA with F8, does the screen do what you are expecting

can all your data be sorted first ? so that all your sheets sit together