Macro not finding filtered value, copying whole data unfiltered. How to prevent this?

jalrs

jalrs

Active Member
Joined
Apr 6, 2022
Messages
300
Office Version
  1. 365
Platform
  1. Windows
Good morning guys,

If my macro doesn't find the filtered value, it is copying all the data which is wrong. How to prevent this? It should either just resume next i value for next filter value or just delete the template lines, leaving row 1 with the headers.

My loop code is as follows:

VBA Code: 
For i = 2 To lr2
        
        valorfiltro = Cells(i, 1).Value
        
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Controlo e Difusão\Templates\ST_TEMPLATE_" & Cells(i, 1).Value & ".xlsx"
        
        Set wb2 = Workbooks("ST_TEMPLATE_" & valorfiltro & ".xlsx")
        
        Set ws3 = wb2.Worksheets("Pendentes")
        
        ws3.Activate
        
        lr3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
        
        ws1.Activate
        
        With ws1.Range("A5:AV" & lr1)
        
            .AutoFilter 46, valorfiltro
            .AutoFilter 47, "Em tratamento"
            
            With ws1
            
                .Range("A6:AV" & lr1).Copy
                ws3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
                
                .Range("BH6:BH" & lr1).Copy
                ws3.Cells(2, 49).PasteSpecial Paste:=xlPasteValues
            
            End With
            
            Application.CutCopyMode = False
            
            .AutoFilter
        
        End With
        
        lr3 = ws3.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row + 1
        ws3.Range("A" & lr3 & ":A1001").EntireRow.Delete
        
        wb2.Activate ' don't think this part of the loop matters
        
        ws3.Activate 'same as above
        
        wb2.RefreshAll 'same as above
        
        Range("A2").Select 'same as above
        
        ws3.Protect Password:="blabla", _ 'same as above
        DrawingObjects:=False, _ 'same as above
        Contents:=True, _ 'same as above
        Scenarios:=False, _ 'same as above
        UserInterfaceOnly:=True, _ 'same as above
        AllowFormattingCells:=True, _ 'same as above
        AllowFormattingColumns:=True, _ 'same as above
        AllowFormattingRows:=True, _ 'same as above
        AllowInsertingColumns:=False, _ 'same as above
        AllowInsertingRows:=False, _ 'same as above
        AllowInsertingHyperlinks:=False, _ 'same as above
        AllowDeletingColumns:=False, _ 'same as above
        AllowDeletingRows:=False, _ 'same as above
        AllowSorting:=True, _ 'same as above
        AllowFiltering:=True, _ 'same as above
        AllowUsingPivotTables:=False 'same as above

        mypath = ThisWorkbook.Path & "\Controlo e Difusão\Partilhas e Regularizações\" 'same as above
            
        wb1.Activate 'same as above
        
        ws2.Activate 'same as above
        
        docname = Cells(i, 5).Value 'same as above
        
        wb2.Activate 'same as above
        
        ws3.Activate 'same as above
        
        ActiveWorkbook.SaveAs Filename:=mypath & docname & ".xlsx", FileFormat:=xlOpenXMLWorkbook 'same as above
    
        ActiveWorkbook.Close 'until here 'same as above
        
    Next i

Any help is greatly appreciated.

Thanks!
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
Try modifying your several .Range("TheRange").Copy to
VBA Code: 
.Range("TheRange").SpecialCells(xlCellTypeVisible).Copy
 
Upvote 0
Anthony47 said:
Try modifying your several .Range("TheRange").Copy to
VBA Code: 
.Range("TheRange").SpecialCells(xlCellTypeVisible).Copy
Click to expand...
Hey Anthony,

Thanks for your reply, I'll try it as soon as I end my lunch.

Thank you for your time!
 
Upvote 0
Anthony47 said:
Try modifying your several .Range("TheRange").Copy to
VBA Code: 
.Range("TheRange").SpecialCells(xlCellTypeVisible).Copy
Click to expand...
Hey Anthony

I tried and I got an error "No cells were found", therefore it couldn't conclude the action.

Thoughts?

Thanks Anthony
 
Upvote 0
You have to articulate your code to test for that condition.
For example:
VBA Code: 
Dim Rng As Range

On Error Resume Next
Set Rng = Range(TheRange).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not Rng Is Nothing Then
    Rng.Copy 
'   your Paste Instructions
End If
 
Upvote 0
Anthony47 said:
You have to articulate your code to test for that condition.
For example:
VBA Code: 
Dim Rng As Range

On Error Resume Next
Set Rng = Range(TheRange).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not Rng Is Nothing Then
    Rng.Copy
'   your Paste Instructions
End If
Click to expand...
Hey Anthony,

Thanks for fast reply, I'll articulate and try it.

Thnk you!
 
Upvote 0
Anthony47 said:
You have to articulate your code to test for that condition.
For example:
VBA Code: 
Dim Rng As Range

On Error Resume Next
Set Rng = Range(TheRange).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not Rng Is Nothing Then
    Rng.Copy
'   your Paste Instructions
End If
Click to expand...
Hi Anthony,

I tried to articulate it, but although I don't get any errors, The desired output is not the one pretended. I have 3 values for "valorfiltro" on column AU. 2 values with no data, and 1 value with data, at the moment.

They are displaying the same output, wrongly, ie, blank sheet from range A2:A. Instead, only the 2 values with no data should have this output.

Articulated code. Sorry for sloppy programming.

VBA Code: 
Option Explicit
Sub filtromacro3()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, i As Long
Dim rng1 As Range
Dim mypath As String, docname As String, valorfiltro As String

Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Stock Trânsito")
Set ws2 = wb1.Worksheets("MACRO 3")

lr1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row

ws2.Activate

    For i = 2 To lr2
        
        valorfiltro = Cells(i, 1).Value
        
        Workbooks.Open Filename:=ThisWorkbook.Path & "\Controlo e Difusão\Templates\ST_TEMPLATE_" & Cells(i, 1).Value & ".xlsx"
        
        Set wb2 = Workbooks("ST_TEMPLATE_" & valorfiltro & ".xlsx")
        
        Set ws3 = wb2.Worksheets("Pendentes")
        
        ws3.Activate
        
        lr3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
        
        ws1.Activate
        
        On Error Resume Next
        
        Set rng1 = ws1.Range("AU6:AU").SpecialCells(xlCellTypeVisible)
        
        On Error GoTo 0
        
        If Not rng1 Is Nothing Then
        
            With ws1.Range("A5:AV" & lr1)
        
                .AutoFilter 47, valorfiltro
            
                With ws1
        
                    .Range("G6:AM" & lr1).Copy
                    ws3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
            
                    .Range("AU6:AU" & lr1).Copy
                    ws3.Cells(2, 34).PasteSpecial Paste:=xlPasteValues
            
                    .Range("BH6:BH" & lr1).Copy
                    ws3.Cells(2, 35).PasteSpecial Paste:=xlPasteValues
            
                    .Range("BN6:BN" & lr1).Copy
                    ws3.Cells(2, 36).PasteSpecial Paste:=xlPasteValues
            
                End With
            
                Application.CutCopyMode = False
            
                AutoFilter
        
            End With
            
        End If
        
        lr3 = ws3.Cells.Find("*", LookIn:=xlValues, SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row + 1
        ws3.Range("A" & lr3 & ":A1001").EntireRow.Delete
        
        wb2.Activate
        
        ws3.Activate
        
        wb2.RefreshAll
        
        Range("A2").Select
        
        ws3.Protect Password:="blabla", _
        DrawingObjects:=False, _
        Contents:=True, _
        Scenarios:=False, _
        UserInterfaceOnly:=True, _
        AllowFormattingCells:=True, _
        AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, _
        AllowInsertingColumns:=False, _
        AllowInsertingRows:=False, _
        AllowInsertingHyperlinks:=False, _
        AllowDeletingColumns:=False, _
        AllowDeletingRows:=False, _
        AllowSorting:=True, _
        AllowFiltering:=True, _
        AllowUsingPivotTables:=False

        mypath = ThisWorkbook.Path & "\Controlo e Difusão\Partilhas e Regularizações\"
            
        wb1.Activate
        
        ws2.Activate
        
        docname = Cells(i, 5).Value
        
        wb2.Activate
        
        ws3.Activate
        
        ActiveWorkbook.SaveAs Filename:=mypath & docname & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
        ActiveWorkbook.Close
        
    Next i
    
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Thanks Anthony
 
Upvote 0
You "play" with Rng1 before applying the filters, that is useless...

The suggested block is
VBA Code: 
            With ws1.Range("A5:AV" & lr1)
                .AutoFilter 47, valorfiltro
                On Error Resume Next
                Set rng1 = ws1.Range("A5:AV" & lr1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng1 Is Nothing Then               'Check there are cells to copy
                'Copy if there are cells to be copied:
                    With ws1                              'Your block
                        .Range("G6:AM" & lr1).Copy
                        ws3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
                
                        .Range("AU6:AU" & lr1).Copy
                        ws3.Cells(2, 34).PasteSpecial Paste:=xlPasteValues
                        
                        .Range("BH6:BH" & lr1).Copy
                        ws3.Cells(2, 35).PasteSpecial Paste:=xlPasteValues
                
                        .Range("BN6:BN" & lr1).Copy
                        ws3.Cells(2, 36).PasteSpecial Paste:=xlPasteValues
                    End With
                End If
'more code
'more code
 
Upvote 0
Anthony47 said:
You "play" with Rng1 before applying the filters, that is useless...

The suggested block is
VBA Code: 
            With ws1.Range("A5:AV" & lr1)
                .AutoFilter 47, valorfiltro
                On Error Resume Next
                Set rng1 = ws1.Range("A5:AV" & lr1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng1 Is Nothing Then               'Check there are cells to copy
                'Copy if there are cells to be copied:
                    With ws1                              'Your block
                        .Range("G6:AM" & lr1).Copy
                        ws3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
               
                        .Range("AU6:AU" & lr1).Copy
                        ws3.Cells(2, 34).PasteSpecial Paste:=xlPasteValues
                       
                        .Range("BH6:BH" & lr1).Copy
                        ws3.Cells(2, 35).PasteSpecial Paste:=xlPasteValues
               
                        .Range("BN6:BN" & lr1).Copy
                        ws3.Cells(2, 36).PasteSpecial Paste:=xlPasteValues
                    End With
                End If
'more code
'more code
Click to expand...
Hey Anthony,

Sorry, that was a bad miss. Still learning as everyday goes by.

Thanks for your time, I will try in a few and report back.

Thank you
 
Upvote 0
Anthony47 said:
You "play" with Rng1 before applying the filters, that is useless...

The suggested block is
VBA Code: 
            With ws1.Range("A5:AV" & lr1)
                .AutoFilter 47, valorfiltro
                On Error Resume Next
                Set rng1 = ws1.Range("A5:AV" & lr1).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng1 Is Nothing Then               'Check there are cells to copy
                'Copy if there are cells to be copied:
                    With ws1                              'Your block
                        .Range("G6:AM" & lr1).Copy
                        ws3.Cells(2, 1).PasteSpecial Paste:=xlPasteValues
               
                        .Range("AU6:AU" & lr1).Copy
                        ws3.Cells(2, 34).PasteSpecial Paste:=xlPasteValues
                       
                        .Range("BH6:BH" & lr1).Copy
                        ws3.Cells(2, 35).PasteSpecial Paste:=xlPasteValues
               
                        .Range("BN6:BN" & lr1).Copy
                        ws3.Cells(2, 36).PasteSpecial Paste:=xlPasteValues
                    End With
                End If
'more code
'more code
Click to expand...
Hey Anthony,

Unfortunately it is not working as it is still copying the whole data.

Thoughts?

Thanks
 
Upvote 0
You must log in or register to reply here.

Similar threads

jalrs
  • Solved
Copying values and not formulas
Replies
8
Views
473
rollis13
rollis13
jalrs
  • Solved
Loop Working but gives me a run Time Error 1004
2
Replies
10
Views
1K
jalrs
jalrs
S
  • Solved
Tweak Macro that Imports specific table columns from a different workbook to filter a column first
Replies
4
Views
177
sspatriots
S
jalrs
  • Solved
PivotTable not Refreshing
2 3 4
Replies
36
Views
2K
Alex Blakenburg
A
I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
273
ItalianPlatinum
I

Forum statistics

Threads
1,215,203
Messages
6,123,627
Members
449,109
Latest member
Sebas8956

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top