Forum Discussion

Copper Contributor

Oct 20, 2020

Solved

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

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....

excel

Subodh_Tiwari_sktneer

Oct 20, 2020

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.

Project to sheet.xlsm30 KB

Subodh_Tiwari_sktneer

Silver Contributor

Oct 20, 2020

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.

RAM98988

Copper Contributor

Oct 20, 2020

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!

Project to sheet.xlsx15 KB

Subodh_Tiwari_sktneer

Silver Contributor

Oct 20, 2020

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.

Project to sheet.xlsm30 KB

RAM98988

Copper Contributor

Oct 20, 2020

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!

Subodh_Tiwari_sktneer

Silver Contributor

Oct 20, 2020

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

Project to sheet v2.xlsm31 KB