VBA - Filter data, copy only visible cells after filter and move onto next filter if no data.

[RAM98988]

Hi, 

I'm currently trying to find a VBA code that will allow me to do the below:

- Filter Column A in sheet 1 

- If the filter returns data then copy this data over to a specific sheet (i.e. sheet 2). But only columns C-I with no headers

- If there is no data in this report that matches the filter then simply move onto the next filter. 

Can anyone help me with this?

Thanks in advance!

[#2]

@RAM98988 

---

@RAM98988 wrote:

Hi, 

I'm currently trying to find a VBA code that will allow me to do the below:

- Filter Column A in sheet 1 

Filter what?

- If the filter returns data then copy this data over to a specific sheet (i.e. sheet 2). But only columns C-I with no headers

- If there is no data in this report that matches the filter then simply move onto the next filter. 

Which next Filter?

Can anyone help me with this?

Yes, we can help if you upload a sample file and explain the steps again considering the data in the sample file. And if required, mock up the desired output manually on Sheet 2.

---

[#3]

@Subodh_Tiwari_sktneer 

Hi attached is a file similar to the one I am working with. 

My aim is for the VBA to filter in 'Sheet 1' column A for 1 

If there is corresponding data copy and paste from C-I (excluding headers) in sheet '1'

If not do not copy anything over.

Then filter column A for 2

If there is corresponding data copy and paste from C-I (excluding headers) in sheet '2'

If not do not copy anything over.

And so on. 

Hopefully this makes more sense. 

Thanks!

[#4 · Accepted solution]

@RAM98988 

Please give this a try and let me know if you get the desired output.

Sub FilterAndCopy()
Dim wsData      As Worksheet
Dim dws         As Worksheet
Dim lr          As Long
Dim x           As Variant
Dim dict        As Object
Dim it          As Variant
Dim i           As Long

Application.ScreenUpdating = False

Set wsData = Worksheets("Sheet1")
lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row

x = wsData.Range("A2:A" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    On Error Resume Next
    Set dws = Worksheets(CStr(it))
    dws.Cells.Clear
    On Error GoTo 0
    If dws Is Nothing Then
        Set dws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        dws.Name = it
    End If
    
    With wsData.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:=it
        wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
        .AutoFilter
    End With
    Set dws = Nothing
Next it

Application.ScreenUpdating = True
End Sub

Please click the button called "Filter And Copy" on Sheet1 in the attached to run the code.

[#5]

@Subodh_Tiwari_sktneer 

Yes thats great thanks. I do have one other query:

If there was already data in the sheets the data is being copied into, is there a way to paste it below that data?

Thanks so much!

[#6]

@RAM98988 

Okay, please give this a try.

And if that takes care of your original question, please take a minute to accept the post with the provided solution as a Best Response to mark your question as Solved.

Sub FilterAndCopy()
Dim wsData      As Worksheet
Dim dws         As Worksheet
Dim lr          As Long
Dim x           As Variant
Dim dict        As Object
Dim it          As Variant
Dim i           As Long
Dim dlr         As Long

Application.ScreenUpdating = False

Set wsData = Worksheets("Sheet1")
lr = wsData.Cells(Rows.Count, "A").End(xlUp).Row

wsData.AutoFilterMode = False

x = wsData.Range("A2:A" & lr).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    dict.Item(x(i, 1)) = ""
Next i

For Each it In dict.keys
    On Error Resume Next
    Set dws = Worksheets(CStr(it))
    On Error GoTo 0
    If dws Is Nothing Then
        Set dws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        dws.Name = it
    End If
    
    With wsData.Range("A1").CurrentRegion
        .AutoFilter field:=1, Criteria1:=it
        dlr = dws.Cells(Rows.Count, "A").End(xlUp).Row
        If dws.Range("A1").Value <> "" Then dlr = dlr + 1
        wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A" & dlr)
        .AutoFilter
    End With
    Set dws = Nothing
Next it

Application.ScreenUpdating = True
End Sub

[#7]

@Subodh_Tiwari_sktneer 

Perfect thank you, out of interest and for potential future reference is it possible to use offsets within this code in order to move the paste range up/down/left/right?

Thanks.

[#8]

@RAM98988 

You're welcome!

Yes, you just need to change the destination range dws.Range("A" & dlr) in the following line as per your requirement.

wsData.Range("C2:I" & lr).SpecialCells(xlCellTypeVisible).Copy dws.Range("A" & dlr)

[#9]

@Subodh_Tiwari_sktneer 

I know this is an old post, but how can I change the column which is being filtered (to column B for example)?

I've tried simply changing:

x = wsData.Range("A2:A" & lr).Value

to 

x = wsData.Range("B2:B" & lr).Value

But I get a run-time error '1004' "No Cells Were Found".

Any suggestions are much appreciated, this is my first time using VBA so I'm a complete beginner!

[#10]

Try to find the last row (lr) for column B also using the below line and see if your issue gets resolved.
lr = wsData.Cells(Rows.Count, "B").End(xlUp).Row

If that doesn't resolve your issue, I would suggest you to open your own question and provide the full details.

[#11]

First of all, thank you very much for the code, @Subodh_Tiwari_sktneer ! It's been super helpful.

@Fliptoe -- I know your question is 6 months old, but here's a potential explanation to the filtering issue. In line 35 of the latest version of Subodh's code:

.AutoFilter field:=1, Criteria1:=it

The field # represents the column it is filtering -- in this case, 1 = column "A"; 2 = column "B"; and so on.

This line works in tandem with code lines 14-18, where you're setting the range of terms for the scripting dictionary. So, if you'd like to filter by column "B", then change the letter "A" to "B" in code lines 14 & 18, and change line 35 to "field:=2".

Hope that helps!

[#12]

Please help me with VBA code, I wanted to apply macro for uneven data. First I want to apply filter and in next blank column I wanna add information about filtered value. Also if filter criteria is nothing then it should proceed to next filter criteria and write my assigned statement to next column.i want to add each filter selection with remarks(which I wanna add in next column)in code itself. I have tried recording macro but due to uneven data it's not working. For example if I've recorded macro for 200 entries and if it turns to 600 then data become wrong. I hope you are getting my query. Please help me with the code or procedure.

I have tried recording macro but it's not working as my data is variable. Every data shows different count of filter criteria but my macro runs for only on recorded cell i.e A1 to A1000