'Filter data using Advanced Filter then copy to the bottom data in another table
I am working on a report that will filter data from a table, then copy that data into another sheet, and then delete the rows from the original table. Below is what I have so far, which works, however, I am not sure how to copy the filtered data into another sheet without erasing what was already there. I am new to VBA, so any notes in code would be appreciated. Thanks!
Sub International_Filter()
Dim Working As Range, IntULD As Range, Copyto As Range
' Working is the datatable that tracking numbers will be filtered, copied, and deleted
' INTULD is a list of criteria that needs to be filtered
' CopyTO is the sheet where the data will be copied
Set Working = Sheets("Working").Range("A1").CurrentRegion
Set IntULD = Sheets("OPC Exception").Range("M6").CurrentRegion
Set Copyto = Sheets("International").Range("A1").CurrentRegion
On Error Resume Next
Sheets("Working").ShowAllData
Working.AdvancedFilter xlFilterCopy, IntULD, Copyto
Working.AdvancedFilter xlFilterInPlace, IntULD
Range("A1").Select
If Range("A9999").End(xlUp).Address = "$A$1" Then
Exit Sub
Else
ActiveCell.Offset(1, 0).Select
If Cells(Columns("A").Rows.Count, "A").End(xlUp).Row > 2 Then
Range(selection, Cells(Columns("A").Rows.Count, "O").End(xlUp)).SpecialCells(xlCellTypeVisible).Select
End If
selection.EntireRow.Delete
End If
On Error Resume Next
Sheets("Working").ShowAllData
End Sub
Solution 1:[1]
How to insert filtered data at the beginning of a destination:
Sub International_Filter()
Dim Source As Range ' Data to look at
Dim Data As Range ' Filtered data to copy
Dim Criteria As Range ' Criteria for Advanced Filter
Dim Destination As Range ' Place to copy filtered data
Dim Area As Range
Set Source = Sheets("Working").Range("A1").CurrentRegion
Set Criteria = Sheets("OPC Exception").Range("M6").CurrentRegion
Set Destination = Sheets("International").Range("A1")
With Source
.AdvancedFilter xlFilterInPlace, Criteria
On Error Resume Next
Set Data = .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData
If Data Is Nothing Then Exit Sub
For Each Area In Data.Areas
Area.Copy
Destination.Insert xlShiftDown
Next Area
Data.Delete xlShiftUp
End With
End Sub
p.s. From my point of view it's better to copy data at the end of existing data. So in this case the last part of the code is:
...
With Sheets("International").UsedRange
Set Destination = .Range("A1").Offset(.Rows.Count)
End With
...
If Data Is Nothing Then Exit Sub
Data.Copy Destination
Data.Delete xlShiftUp
...
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
| Solution | Source |
|---|---|
| Solution 1 |
