Cut & Paste Special Cells from Sheet 1 to Sheet 2, Then Delete Blanks

[Frenzyy]

Hi, I'm currently working on a macro which would allow me to cut & paste filtered data from one sheet to another, then come back to the original sheet and get rid of the blank rows that are left. Originally, I was able to get around the problem of cutting unwanted data by sorting several columns and then it somehow worked but now the order of data is more random and from the research I've done, it looks like I'll have to use 'special cells'. However, I can't get it work properly and the macro now crashes on the 'Cut' line.


I'd greatly appreciate if you could please help me out with this.

Application.ScreenUpdating = False
Sheets("SheetX").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("SheetX".AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SheetX".AutoFilter.Sort.SortFields.Add Key:= _
Range("I1", SortOn:=xlSortOnValues, Order:= xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("SheetX".AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$W$1").AutoFilter Field:=10, Criteria 1:="=Criteria 1" xlOr Criteria 2:="=Criteria 2"
ActiveSheet.Range("$A$1:$W$1").AutoFilter Field:=12, Criteria 1:="=*Criteria Y*"
Range("A2:W2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Cut
Sheets("SheetZ").Select
Range("A2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1,0).Range("A1").Select
ActiveSheet.Paste
Sheets("SheetX").Select
Selection.EntireRow.Delete
Selection.AutoFilter
Application.ScreenUpdating = True

I know there are most likely better, more efficient ways to go about this than what I've done above so by all means feel free to change/remove code.
Thanks in advance!

 

[dmt32]

Hi Welcome to forum

Untested but see if this update to your code does what you want

Sub FilterCopyDelete()
    Dim SheetX As Worksheet, SheetZ As Worksheet
    Dim rng As Range
    Dim VisibleRows As Long
    
    With ThisWorkbook
        Set SheetX = .Worksheets("SheetX")
        Set SheetZ = .Worksheets("SheetZ")
    End With
    
    With SheetX
        .UsedRange.AutoFilter
        .AutoFilter.Sort.SortFields.Clear
        .AutoFilter.Sort.SortFields.Add Key:= _
        .Range("I1"), SortOn:=xlSortOnValues, _
                      Order:=xlAscending, _
                      DataOption:=xlSortNormal
                      
        With .AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        With .UsedRange
            .AutoFilter Field:=10, Criteria1:="=Criteria 1", Operator:=xlOr, Criteria2:="=Criteria 2"
            .AutoFilter Field:=12, Criteria1:="=*Criteria Y*"
        End With
        
        Set rng = .AutoFilter.Range
        
    End With
    
'count visible rows
    VisibleRows = rng.Columns(10).SpecialCells(xlCellTypeVisible).Count - 1
    
    If VisibleRows > 0 Then
'exclude header row
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
'copy to sheetZ
        rng.SpecialCells(xlCellTypeVisible).Copy SheetZ.Range("A2")
'delete copied rows
        rng.EntireRow.Delete
    End If
're-set autofilter
    rng.AutoFilter
End Sub

Code may need adjusting to meet specific project need but hopefully goes in right direction for you.

Dave

 

[Frenzyy]

Hi Dave, thank you for the quick response.

I'm not sure if I'm doing something wrong but for some reason I get a 'Subscript out of range '9'' error on the line where SheetX is being declared. The name provided is correct and yet it crashes, unfortunately.
Any ideas?

Let me know if you'd like me to provide you with a copy of the workbook with some dummy data.

Thank you in advance.

 

[dmt32]

Hi Dave, thank you for the quick response.

I'm not sure if I'm doing something wrong but for some reason I get a 'Subscript out of range '9'' error on the line where SheetX is being declared. The name provided is correct and yet it crashes, unfortunately.
Any ideas?

Let me know if you'd like me to provide you with a copy of the workbook with some dummy data.

Thank you in advance.

The error means code cannot find sheet with that name. Check tab name in same workbook is correct which should be SheetX and not something like Sheet X

If still having problems, place copy of workbook in a dropbox & provide link to it here.

Dave

 

[Frenzyy]

Please see the attached here: https://uploadfiles.io/9gq0jy1f
I ran the below code on it but I get an error on ' .UsedRange.AutoFilter' now.

Sub FilterCopyDelete()
    Dim Sheet1 As Worksheet, Sheet2 As Worksheet
    Dim rng As Range
    Dim VisibleRows As Long
    
    With ThisWorkbook
        Set Sheet1 = .Worksheets("Sheet1")
        Set Sheet2 = .Worksheets("Sheet2")
    End With
    
    With Sheet1
        .UsedRange.AutoFilter
        .AutoFilter.Sort.SortFields.Clear
        .AutoFilter.Sort.SortFields.Add Key:= _
        .Range("I1"), SortOn:=xlSortOnValues, _
                      Order:=xlAscending, _
                      DataOption:=xlSortNormal

' I assume that sorting won't be needed anymore if the special cells cut & paste will work?
                      
        With .AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        With .UsedRange
            .AutoFilter Field:=10, Criteria1:="=Filter - X", Operator:=xlOr, Criteria2:="=Filter - Y"
            .AutoFilter Field:=12, Criteria1:="=*Copy Me*"
        End With
        
        Set rng = .AutoFilter.Range
        
    End With
    
'count visible rows
    VisibleRows = rng.Columns(10).SpecialCells(xlCellTypeVisible).Count - 1
    
    If VisibleRows > 0 Then
'exclude header row
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
'copy to sheetZ
        rng.SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("A2")
'delete copied rows
        rng.EntireRow.Delete
    End If
're-set autofilter
    rng.AutoFilter
End Sub

Thank you

 

[dmt32]

Since your first post, you have changed the names of the sheets & the object variables for your sheet names using the name (Sheet1) this name is most likely is a sheet codename for another sheet which may explain the error

See if this update helps

Sub FilterCopyDelete()
    Dim wsSheet1 As Worksheet, wsSheet2 As Worksheet
    Dim rng As Range
    Dim VisibleRows As Long
    
    With ThisWorkbook
        Set wsSheet1 = .Worksheets("Sheet1")
        Set wsSheet2 = .Worksheets("Sheet2")
    End With
    
    With wsSheet1.UsedRange
            .AutoFilter
            .AutoFilter Field:=10, Criteria1:="=Filter - X", Operator:=xlOr, Criteria2:="=Filter - Y"
            .AutoFilter Field:=12, Criteria1:="=*Copy Me*"
    End With
    
    Set rng = wsSheet1.AutoFilter.Range
    
'count visible rows
    VisibleRows = rng.Columns(10).SpecialCells(xlCellTypeVisible).Count - 1
    
    If VisibleRows > 0 Then
'exclude header row
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
'copy to wssheet2
        rng.SpecialCells(xlCellTypeVisible).Copy wsSheet2.Range("A2")
'delete copied rows
        rng.EntireRow.Delete
    End If
're-set autofilter
    rng.AutoFilter
End Sub

You indicated that you may not now need the sort part of the code so I have removed it but you can add it back if this is incorrect.


Dave

 

[Fluff]

Cross posted https://www.excelforum.com/excel-pr...om-sheet-1-to-sheet-2-then-delete-blanks.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[dmt32]

Cross posted

thanks Fluff.

Dave

 

[Frenzyy]

Cross posted https://www.excelforum.com/excel-pr...om-sheet-1-to-sheet-2-then-delete-blanks.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

Understood, I'll make sure to do so in the future. Thank you Fluff.

Since your first post, you have changed the names of the sheets & the object variables for your sheet names using the name (Sheet1) this name is most likely is a sheet codename for another sheet which may explain the error

See if this update helps

Sub FilterCopyDelete()
    Dim wsSheet1 As Worksheet, wsSheet2 As Worksheet
    Dim rng As Range
    Dim VisibleRows As Long
    
    With ThisWorkbook
        Set wsSheet1 = .Worksheets("Sheet1")
        Set wsSheet2 = .Worksheets("Sheet2")
    End With
    
    With wsSheet1.UsedRange
            .AutoFilter
            .AutoFilter Field:=10, Criteria1:="=Filter - X", Operator:=xlOr, Criteria2:="=Filter - Y"
            .AutoFilter Field:=12, Criteria1:="=*Copy Me*"
    End With
    
    Set rng = wsSheet1.AutoFilter.Range
    
'count visible rows
    VisibleRows = rng.Columns(10).SpecialCells(xlCellTypeVisible).Count - 1
    
    If VisibleRows > 0 Then
'exclude header row
        Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
'copy to wssheet2
        rng.SpecialCells(xlCellTypeVisible).Copy wsSheet2.Range("A2")
'delete copied rows
        rng.EntireRow.Delete
    End If
're-set autofilter
    rng.AutoFilter
End Sub

You indicated that you may not now need the sort part of the code so I have removed it but you can add it back if this is incorrect.


Dave

Hey Dave, it now does exactly what I wanted it to do with the exception of the fact that everything is being pasted over the data already present in Sheet2. What would be the best way to use the 'Offset' (I assume) function to make sure that the data is always pasted after the last row in the table, which always varies in size?
Thank you in advance!

 

[dmt32]

try changing this line

rng.SpecialCells(xlCellTypeVisible).Copy wsSheet2.Range("A2")

to this

rng.SpecialCells(xlCellTypeVisible).Copy wsSheet2.Cells(wsSheet2.UsedRange.Rows.Count + 1, 1)

and see if it does what you want

Dave