vhrame
05-27-2020, 11:13 AM
Good Afternoon All,
I am working on some code to filter a table on a worksheet (Sheet1) and to copy and paste the results onto another sheet (sheet2).
I have a table with 1 column called "Arms Prof#" and it has a range of values in it such as (SUR20, EFM21, WHC20, and some are blank). My goal is to have just the WHC20 records pasted into Sheet2. However, my message box comes back with a message saying "no data available to copy".
So what I thought I would try is removing the blanks manually on Sheet1 and seeing if the code worked then, and it did. So to me it seems like its an issue with the blank cells. This is what I have so far:
Sub copyfiltereddata()
Dim rng As Range
Dim autofiltrng As Range
With ActiveSheet
.Range("A1").AutoFilter field:=1, Criteria1:="WHC20"
End With
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set autofiltrng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If autofiltrng Is Nothing Then
MsgBox "no data available for copy"
Else
Worksheets("Sheet2").Cells.Clear
Sheet2.Range("A1") = "Arms Prof#"
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A2")
End If
ActiveSheet.ShowAllData
End Sub
Any help would be appreciated!
I am working on some code to filter a table on a worksheet (Sheet1) and to copy and paste the results onto another sheet (sheet2).
I have a table with 1 column called "Arms Prof#" and it has a range of values in it such as (SUR20, EFM21, WHC20, and some are blank). My goal is to have just the WHC20 records pasted into Sheet2. However, my message box comes back with a message saying "no data available to copy".
So what I thought I would try is removing the blanks manually on Sheet1 and seeing if the code worked then, and it did. So to me it seems like its an issue with the blank cells. This is what I have so far:
Sub copyfiltereddata()
Dim rng As Range
Dim autofiltrng As Range
With ActiveSheet
.Range("A1").AutoFilter field:=1, Criteria1:="WHC20"
End With
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set autofiltrng = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If autofiltrng Is Nothing Then
MsgBox "no data available for copy"
Else
Worksheets("Sheet2").Cells.Clear
Sheet2.Range("A1") = "Arms Prof#"
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy Destination:=Worksheets("Sheet2").Range("A2")
End If
ActiveSheet.ShowAllData
End Sub
Any help would be appreciated!