Using UsedRange copies empty rows at the end

[DJhuffman]

Here's a bit of a puzzler. I built a code to do the following steps:

1. Apply a filter
2. Copy visible cells
3. Paste the visible cells to a new sheet
4. Rename the new sheet
5. Migrate back to the old sheet and delete the visible rows (thus removing them from the unfiltered data)

Trouble is, when the process is done, the active range (as determined by Ctrl+Shift+End) is showing row 1,000,000 (when I only copied over a few thousand rows). Is there something I can do to prevent this from happening?

Here's a sample of the code. Any help is always appreciated.

Sub lite360()


    ActiveSheet.UsedRange.AutoFilter Field:=11, Criteria1:="-"
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "ZERO BALANCE"
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
    
    ActiveSheet.UsedRange.AutoFilter Field:=4
    ActiveSheet.UsedRange.AutoFilter Field:=11
    ActiveSheet.UsedRange.AutoFilter Field:=13, Criteria1:="O"
    Range("A1").Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "OP"
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete

End Sub

 

[DanteAmor]

This is the problem
Change these lines:

    'Selection.SpecialCells(xlCellTypeVisible).Select
    'Selection.Copy

By:

    ActiveSheet.AutoFilter.Range.Copy

Then continue your code, but I do not understand what to do, because I do not know the sheets, I understand that the filter starts on the "Sheet1" and the result you paste on a new sheet, but I do not understand what you do with the "Sheet2".

Try the change and tell me.

 

[DJhuffman]

I'm a bit speechless at how much faster that made the processing: from 2 minutes to five seconds.
The process isn't perfected yet, but this is an amazing improvement. The new sheets are generating just fine.
At this point, the problem seems to be that if there are no rows of data to delete from a prior move, the process delete's the top row (which throws off subsequent steps).

The following code is how things stand now (with your substitutions)

Sub lite360()


    ActiveSheet.UsedRange.AutoFilter Field:=11, Criteria1:="-"
    ActiveSheet.AutoFilter.Range.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Sheets("Sheet2").Select
    Sheets("Sheet2").Name = "ZERO BALANCE"
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Application.CutCopyMode = False
    Selection.EntireRow.Delete
    
    ActiveSheet.UsedRange.AutoFilter Field:=4
    ActiveSheet.UsedRange.AutoFilter Field:=11
    ActiveSheet.UsedRange.AutoFilter Field:=13, Criteria1:="O"
    Range("A1").Select
    ActiveSheet.AutoFilter.Range.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "OP"
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select   <--- The problem seems to be here
    Application.CutCopyMode = False
    Selection.EntireRow.Delete

The first set of instructions works fine, moving filtered items to the new tab, renaming the new sheet, and deleting them from the original sheet. However, for the second set of instructions, there is technically no data to move other than the first row (which heads all the sheets). The macro is able to move the top row, but when it goes back to the original sheet, it selects the top row to delete (thus breaking down the sequence). If there is a more efficient way to clear the visible rows from the data while maintaining the top row, I'm open to suggestions.

Thank you for your time.

 

[DanteAmor]

before copying, check if the last row with data is equal to 1

 

[DJhuffman]

Is there a way I can incorporate that into the macro? I presume this would be a case of:

If last row with data = 1, Then
Copy row 1 to new spreadsheet
Return to original spreadsheet
Else
Run the macro how I originally was operating
End If

I'd probably have to incorporate that If Else for each set of data to be moved, which is not an issue. But how would I go about getting the macro to check if the last row with data = 1?

 

[DanteAmor]

Try this

    ActiveSheet.UsedRange.AutoFilter Field:=11, Criteria1:="-"
    ActiveSheet.AutoFilter.Range.Copy
    lr = ActiveSheet.Range("A" & rows.count).end(xlup).row
    if lr = 1 then 

       msgbox "[COLOR=#333333]no data to move"
[/COLOR]
    else

      Sheets.Add After:=ActiveSheet
      ActiveSheet.Paste
      Selection.Columns.AutoFit
      Sheets("Sheet2").Select
      Sheets("Sheet2").Name = "ZERO BALANCE"
      Sheets("Sheet1").Select
      Range("A2").Select
      Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
      Application.CutCopyMode = False
      Selection.EntireRow.Delete

    end if    


    ActiveSheet.UsedRange.AutoFilter Field:=4    ActiveSheet.UsedRange.AutoFilter Field:=11
    ActiveSheet.UsedRange.AutoFilter Field:=13, Criteria1:="O"
    Range("A1").Select
    ActiveSheet.AutoFilter.Range.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Selection.Columns.AutoFit
    Sheets("Sheet3").Select
    Sheets("Sheet3").Name = "OP"
    Sheets("Sheet1").Select
    Range("A2").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select   <--- The problem seems to be here
    Application.CutCopyMode = False
    Selection.EntireRow.Delete

 

[DJhuffman]

Ok, now we're talking! I had to tinker with the else if instructions slightly to apply separate instructions to each case, but your instructions were spot on. Thank you so much for your patience and help!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.