SOLVED

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

%3CLINGO-SUB%20id%3D%22lingo-sub-1798398%22%20slang%3D%22en-US%22%3EVBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1798398%22%20slang%3D%22en-US%22%3E%3CP%3EHi%2C%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EI'm%20currently%20trying%20to%20find%20a%20VBA%20code%20that%20will%20allow%20me%20to%20do%20the%20below%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E-%20Filter%20Column%20A%20in%20sheet%201%26nbsp%3B%3C%2FP%3E%3CP%3E-%20If%20the%20filter%20returns%20data%20then%20copy%20this%20data%20over%20to%20a%20specific%20sheet%20(i.e.%20sheet%202).%20But%20only%20columns%20C-I%20with%20no%20headers%3C%2FP%3E%3CP%3E-%20If%20there%20is%20no%20data%20in%20this%20report%20that%20matches%20the%20filter%20then%20simply%20move%20onto%20the%20next%20filter.%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3ECan%20anyone%20help%20me%20with%20this%3F%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThanks%20in%20advance!%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-1798398%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EExcel%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E%3CLINGO-SUB%20id%3D%22lingo-sub-1798841%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1798841%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F838854%22%20target%3D%22_blank%22%3E%40RAM98988%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CBLOCKQUOTE%3E%3CHR%20%2F%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F838854%22%20target%3D%22_blank%22%3E%40RAM98988%3C%2FA%3E%26nbsp%3Bwrote%3A%3C%2FEM%3E%3C%2FFONT%3E%3CBR%20%2F%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3EHi%2C%26nbsp%3B%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3EI'm%20currently%20trying%20to%20find%20a%20VBA%20code%20that%20will%20allow%20me%20to%20do%20the%20below%3A%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3E-%20Filter%20Column%20A%20in%20sheet%201%26nbsp%3B%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%3CSTRONG%3EFilter%20what%3F%3C%2FSTRONG%3E%3C%2FP%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3E-%20If%20the%20filter%20returns%20data%20then%20copy%20this%20data%20over%20to%20a%20specific%20sheet%20(i.e.%20sheet%202).%20But%20only%20columns%20C-I%20with%20no%20headers%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3E-%20If%20there%20is%20no%20data%20in%20this%20report%20that%20matches%20the%20filter%20then%20simply%20move%20onto%20the%20next%20filter.%26nbsp%3B%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%3CSTRONG%3EWhich%20next%20Filter%3F%3C%2FSTRONG%3E%3C%2FP%3E%3CP%3E%3CFONT%20color%3D%22%23808080%22%3E%3CEM%3ECan%20anyone%20help%20me%20with%20this%3F%3C%2FEM%3E%3C%2FFONT%3E%3C%2FP%3E%3CP%3E%3CSTRONG%3EYes%2C%20we%20can%20help%20if%20you%20upload%20a%20sample%20file%20and%20explain%20the%20steps%20again%20considering%20the%20data%20in%20the%20sample%20file.%20And%20if%20required%2C%20mock%20up%20the%20desired%20output%20manually%20on%20Sheet%202.%3C%2FSTRONG%3E%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CHR%20%2F%3E%3C%2FBLOCKQUOTE%3E%3CP%3E%3CBR%20%2F%3E%3CBR%20%2F%3E%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-1798891%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1798891%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F394231%22%20target%3D%22_blank%22%3E%40Subodh_Tiwari_sktneer%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EHi%20attached%20is%20a%20file%20similar%20to%20the%20one%20I%20am%20working%20with.%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EMy%20aim%20is%20for%20the%20VBA%20to%20filter%20in%20'Sheet%201'%20column%20A%20for%201%26nbsp%3B%3C%2FP%3E%3CP%3EIf%20there%20is%20corresponding%20data%20copy%20and%20paste%20from%20C-I%20(excluding%20headers)%20in%20sheet%20'1'%3C%2FP%3E%3CP%3EIf%20not%20do%20not%20copy%20anything%20over.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThen%20filter%20column%20A%20for%202%3C%2FP%3E%3CP%3EIf%20there%20is%20corresponding%20data%20copy%20and%20paste%20from%20C-I%20(excluding%20headers)%20in%20sheet%20'2'%3C%2FP%3E%3CP%3EIf%20not%20do%20not%20copy%20anything%20over.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EAnd%20so%20on.%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EHopefully%20this%20makes%20more%20sense.%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThanks!%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-1799298%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1799298%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F838854%22%20target%3D%22_blank%22%3E%40RAM98988%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPlease%20give%20this%20a%20try%20and%20let%20me%20know%20if%20you%20get%20the%20desired%20output.%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-applescript%22%3E%3CCODE%3ESub%20FilterAndCopy()%0ADim%20wsData%20%20%20%20%20%20As%20Worksheet%0ADim%20dws%20%20%20%20%20%20%20%20%20As%20Worksheet%0ADim%20lr%20%20%20%20%20%20%20%20%20%20As%20Long%0ADim%20x%20%20%20%20%20%20%20%20%20%20%20As%20Variant%0ADim%20dict%20%20%20%20%20%20%20%20As%20Object%0ADim%20it%20%20%20%20%20%20%20%20%20%20As%20Variant%0ADim%20i%20%20%20%20%20%20%20%20%20%20%20As%20Long%0A%0AApplication.ScreenUpdating%20%3D%20False%0A%0ASet%20wsData%20%3D%20Worksheets(%22Sheet1%22)%0Alr%20%3D%20wsData.Cells(Rows.Count%2C%20%22A%22).End(xlUp).Row%0A%0Ax%20%3D%20wsData.Range(%22A2%3AA%22%20%26amp%3B%20lr).Value%0ASet%20dict%20%3D%20CreateObject(%22Scripting.Dictionary%22)%0A%0AFor%20i%20%3D%201%20To%20UBound(x%2C%201)%0A%20%20%20%20dict.Item(x(i%2C%201))%20%3D%20%22%22%0ANext%20i%0A%0AFor%20Each%20it%20In%20dict.keys%0A%20%20%20%20On%20Error%20Resume%20Next%0A%20%20%20%20Set%20dws%20%3D%20Worksheets(CStr(it))%0A%20%20%20%20dws.Cells.Clear%0A%20%20%20%20On%20Error%20GoTo%200%0A%20%20%20%20If%20dws%20Is%20Nothing%20Then%0A%20%20%20%20%20%20%20%20Set%20dws%20%3D%20Worksheets.Add(after%3A%3DWorksheets(Worksheets.Count))%0A%20%20%20%20%20%20%20%20dws.Name%20%3D%20it%0A%20%20%20%20End%20If%0A%20%20%20%20%0A%20%20%20%20With%20wsData.Range(%22A1%22).CurrentRegion%0A%20%20%20%20%20%20%20%20.AutoFilter%20field%3A%3D1%2C%20Criteria1%3A%3Dit%0A%20%20%20%20%20%20%20%20wsData.Range(%22C2%3AI%22%20%26amp%3B%20lr).SpecialCells(xlCellTypeVisible).Copy%20dws.Range(%22A1%22)%0A%20%20%20%20%20%20%20%20.AutoFilter%0A%20%20%20%20End%20With%0A%20%20%20%20Set%20dws%20%3D%20Nothing%0ANext%20it%0A%0AApplication.ScreenUpdating%20%3D%20True%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3EPlease%20click%20the%20button%20called%20%22Filter%20And%20Copy%22%20on%20Sheet1%20in%20the%20attached%20to%20run%20the%20code.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-1799444%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1799444%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F394231%22%20target%3D%22_blank%22%3E%40Subodh_Tiwari_sktneer%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EYes%20thats%20great%20thanks.%20I%20do%20have%20one%20other%20query%3A%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EIf%20there%20was%20already%20data%20in%20the%20sheets%20the%20data%20is%20being%20copied%20into%2C%20is%20there%20a%20way%20to%20paste%20it%20below%20that%20data%3F%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EThanks%20so%20much!%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-SUB%20id%3D%22lingo-sub-1799879%22%20slang%3D%22en-US%22%3ERe%3A%20VBA%20-%20Filter%20data%2C%20copy%20only%20visible%20cells%20after%20filter%20and%20move%20onto%20next%20filter%20if%20no%20data.%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1799879%22%20slang%3D%22en-US%22%3E%3CP%3E%3CA%20href%3D%22https%3A%2F%2Ftechcommunity.microsoft.com%2Ft5%2Fuser%2Fviewprofilepage%2Fuser-id%2F838854%22%20target%3D%22_blank%22%3E%40RAM98988%3C%2FA%3E%26nbsp%3B%3C%2FP%3E%3CP%3EOkay%2C%20please%20give%20this%20a%20try.%3C%2FP%3E%3CP%3EAnd%20if%20that%20takes%20care%20of%20your%20original%20question%2C%20please%20take%20a%20minute%20to%20accept%20the%20post%20with%20the%20provided%20solution%20as%20a%20Best%20Response%20to%20mark%20your%20question%20as%20Solved.%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CPRE%20class%3D%22lia-code-sample%20language-applescript%22%3E%3CCODE%3ESub%20FilterAndCopy()%0ADim%20wsData%20%20%20%20%20%20As%20Worksheet%0ADim%20dws%20%20%20%20%20%20%20%20%20As%20Worksheet%0ADim%20lr%20%20%20%20%20%20%20%20%20%20As%20Long%0ADim%20x%20%20%20%20%20%20%20%20%20%20%20As%20Variant%0ADim%20dict%20%20%20%20%20%20%20%20As%20Object%0ADim%20it%20%20%20%20%20%20%20%20%20%20As%20Variant%0ADim%20i%20%20%20%20%20%20%20%20%20%20%20As%20Long%0ADim%20dlr%20%20%20%20%20%20%20%20%20As%20Long%0A%0AApplication.ScreenUpdating%20%3D%20False%0A%0ASet%20wsData%20%3D%20Worksheets(%22Sheet1%22)%0Alr%20%3D%20wsData.Cells(Rows.Count%2C%20%22A%22).End(xlUp).Row%0A%0AwsData.AutoFilterMode%20%3D%20False%0A%0Ax%20%3D%20wsData.Range(%22A2%3AA%22%20%26amp%3B%20lr).Value%0ASet%20dict%20%3D%20CreateObject(%22Scripting.Dictionary%22)%0A%0AFor%20i%20%3D%201%20To%20UBound(x%2C%201)%0A%20%20%20%20dict.Item(x(i%2C%201))%20%3D%20%22%22%0ANext%20i%0A%0AFor%20Each%20it%20In%20dict.keys%0A%20%20%20%20On%20Error%20Resume%20Next%0A%20%20%20%20Set%20dws%20%3D%20Worksheets(CStr(it))%0A%20%20%20%20On%20Error%20GoTo%200%0A%20%20%20%20If%20dws%20Is%20Nothing%20Then%0A%20%20%20%20%20%20%20%20Set%20dws%20%3D%20Worksheets.Add(after%3A%3DWorksheets(Worksheets.Count))%0A%20%20%20%20%20%20%20%20dws.Name%20%3D%20it%0A%20%20%20%20End%20If%0A%20%20%20%20%0A%20%20%20%20With%20wsData.Range(%22A1%22).CurrentRegion%0A%20%20%20%20%20%20%20%20.AutoFilter%20field%3A%3D1%2C%20Criteria1%3A%3Dit%0A%20%20%20%20%20%20%20%20dlr%20%3D%20dws.Cells(Rows.Count%2C%20%22A%22).End(xlUp).Row%0A%20%20%20%20%20%20%20%20If%20dws.Range(%22A1%22).Value%20%26lt%3B%26gt%3B%20%22%22%20Then%20dlr%20%3D%20dlr%20%2B%201%0A%20%20%20%20%20%20%20%20wsData.Range(%22C2%3AI%22%20%26amp%3B%20lr).SpecialCells(xlCellTypeVisible).Copy%20dws.Range(%22A%22%20%26amp%3B%20dlr)%0A%20%20%20%20%20%20%20%20.AutoFilter%0A%20%20%20%20End%20With%0A%20%20%20%20Set%20dws%20%3D%20Nothing%0ANext%20it%0A%0AApplication.ScreenUpdating%20%3D%20True%0AEnd%20Sub%3C%2FCODE%3E%3C%2FPRE%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3C%2FLINGO-BODY%3E
Highlighted
Occasional Contributor

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!

7 Replies
Highlighted

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

 




Highlighted

@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!

Highlighted
Best Response confirmed by RAM98988 (Occasional Contributor)
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.

 

 

Highlighted

@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!

Highlighted

@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

 

Highlighted

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

Highlighted

@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)