Loop through AutoFiltered range

K1600

Board Regular
Joined
Oct 20, 2017
Messages
166
I have code which is running an AutoFilter on existing data and is working fine. I am now trying to loop through each row of filtered data to be able to present it in a UserForm where the user then has the option to amend the data by choosing 'yes' or 'no' from a radio button. There are 18 rows of test data in my spreadsheet and when the AutoFilter runs that drops to 4 rows which is correct. When I run my current 'for' loop it only runs on the top two rows. When I have looked deeper into it, the loop starts correctly at the first filtered row but stops when the next row is not in the filtered range. So, my first two rows are 11 and 12 which run fine but then the next two in the filtered range are rows 17 and 18 (because 13 - 16 have been filtered out) which the loop never goes to as it stops after it completes the process on row 12.

I added the (xlCellTypeVisible) part which has stopped it looping through all 18 rows but I now just need it to loop all the filtered results.

If anyone can suggest anything I would be most grateful. This is my current code:

VBA Code:
With Worksheets("Pro")
    Set rngColVRM = .Range("Table8[VRM / ID]").SpecialCells(xlCellTypeVisible)
    Set rngColDate = .Range("Table8[Date]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect1 = .Range("Table8[Defect 1]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect2 = .Range("Table8[Defect 2]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect3 = .Range("Table8[Defect 3]").SpecialCells(xlCellTypeVisible)
    Set rngColMOTDate = .Range("Table8[Last MOT date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatus = .Range("Table8[Status]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusDate = .Range("Table8[Status Update Date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusOff = .Range("Table8[Updated by]").SpecialCells(xlCellTypeVisible)
    Set rngColDateMOTChecked = .Range("Table8[Date MOT checked]").SpecialCells(xlCellTypeVisible)
    Set rngColComplete = .Range("Table8[Complete]").SpecialCells(xlCellTypeVisible)
End With

Dim lastrow As Long
'Used to check number of responses in AutoFilter
    lastrow = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
    Debug.Print lastrow
    If lastrow < 1 Then 'Stops process if there are no entries matching criteria of AutoFilter
        '    MsgBox ("Filter empty")
        Exit Sub
    Else
            UFCheck.TxtRowNumber.Text = lastrow
    End If

For r = 1 To rngColVRM.Rows.Count

    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(r).Value
    .TxtDate.Text = rngColDate.Cells(r).Value
    .TxtDefect1.Text = rngColDefect1.Cells(r).Value
    .TxtDefect2.Text = rngColDefect2.Cells(r).Value
    .TxtDefect3.Text = rngColDefect3.Cells(r).Value
    .TxtMOTDate.Text = rngColMOTDate.Cells(r).Value
    UFCheck.Show
        If .OptClearYes.Value = True Then
            rngColStatus.Value = "Reviewed - System generated"
            rngColStatusDate.Value = Date
            rngColStatusOff.Value = UserName & " - System generated"
            rngColComplete.Value = "Yes"
            Worksheets("Removed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = rngColVRM.Cells(r).Value
            Worksheets("Removed").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Now
    
            .TxtVRM.Text = rngColVRM.Cells(r).Value
            .TxtDate.Text = ""
            .TxtDefect1.Text = ""
            .TxtDefect2.Text = ""
            .TxtDefect3.Text = ""
            .TxtMOTDate.Text = ""
            .OptClearNo.Value = False
            .OptClearYes.Value = False
            .TxtRowNumber.Text = .TxtRowNumber.Value - 1
        End If
    End With
Next
 

Some videos you may like

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,962
Office Version
  1. 365
Platform
  1. Windows
Here's an example:
VBA Code:
Sub a1160843a()

With Range("A1:B8")

    .AutoFilter Field:=1, Criteria1:="L"
    
    For Each c In .Offset(1).Columns(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        Debug.Print c.Address
    Next

End With

End Sub

Debug.Print result:
$A$3
$A$5
$A$6


Book1
AB
1dataname
2QRodrigo
3LMakai
4YPatrick
5LJermaine
6LAriel
7YAnson
8JIsaiah
9
10
Sheet1


Book1
AB
1dataname
3LMakai
5LJermaine
6LAriel
9
10
Sheet1
 

K1600

Board Regular
Joined
Oct 20, 2017
Messages
166
Here's an example:
VBA Code:
Sub a1160843a()

With Range("A1:B8")

    .AutoFilter Field:=1, Criteria1:="L"
   
    For Each c In .Offset(1).Columns(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        Debug.Print c.Address
    Next

End With

End Sub

Debug.Print result:
$A$3
$A$5
$A$6


Book1
AB
1dataname
2QRodrigo
3LMakai
4YPatrick
5LJermaine
6LAriel
7YAnson
8JIsaiah
9
10
Sheet1


Book1
AB
1dataname
3LMakai
5LJermaine
6LAriel
9
10
Sheet1
Thanks Akuini, where would I need to put that within my code? I've tried a couple of places but can't get it to work but I'm relatively new to vba so it's a bit of trial an error for me at the minute.
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,962
Office Version
  1. 365
Platform
  1. Windows
I don't understand your code. It looks like you have a bunch of filtered tables & you want to sent the filtered cells value to some textboxes in a userform.
Could you upload a sample workbook (without sensitive data) to a free site such as dropbox.com or google drive & then share the link here?
And explain what you're trying to do in more detail by using an example.
 

K1600

Board Regular
Joined
Oct 20, 2017
Messages
166

ADVERTISEMENT

I don't understand your code. It looks like you have a bunch of filtered tables & you want to sent the filtered cells value to some textboxes in a userform.
Could you upload a sample workbook (without sensitive data) to a free site such as dropbox.com or google drive & then share the link here?
And explain what you're trying to do in more detail by using an example.
This just relates to one table (Table8) which is in a sheet named "Pro". The only exception to that is where it adds an entry onto a sheet named "Removed" but that is just putting a value from the userform and the current date/time into two cells and is all working correctly.

When the code runs, it applies autofilter to four columns which again is working fine.

From For r = 1 To rngColVRM.Rows.Count it then just loops through each row of filtered data and puts it in the userform "UFCheck". From here the user can click only click on two radio buttons to select "yes" or "no" then click 'Next' on the userform. If they have selected "no", it just clears the form and moves onto the next row of data, if they select "yes" then it adds some entries into the row of data. This bit works fine outside of the data being filtered and it will loop through all 18 routes of my test data.

When the data is filtered, it drops from 18 rows of data to 4, these rows on my current dataset being rows 11, 12, 17 & 18. The remaining rows are hidden due to the filters.

The code works fine up to and including row 12 (or whatever the last row is before there is a gap in row number) but after this the loop stops running and doesn't move on to the next row, in this case, row 17.

If this still doesn't make sense I will mock up another file with it in for you, I can't use my current one as it would take me an age to sanitise as its got sensitive data all over the place including in some of the coding.

Thanks for your help.
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,962
Office Version
  1. 365
Platform
  1. Windows
Without seeing the table, I'm guessing:

Rich (BB code):
For Each r In rngColVRM

    n = r.Row - rngColVRM.Row + 1
    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(n).Value
    .TxtDate.Text = rngColDate.Cells(n).Value
    '..... etc
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,962
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Sorry, I meant replace this part:
VBA Code:
For r = 1 To rngColVRM.Rows.Count

    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(r).Value
    .TxtDate.Text = rngColDate.Cells(r).Value

with the code in post #6 & and adjust the next lines
 

K1600

Board Regular
Joined
Oct 20, 2017
Messages
166
Sorry, I meant replace this part:
VBA Code:
For r = 1 To rngColVRM.Rows.Count

    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(r).Value
    .TxtDate.Text = rngColDate.Cells(r).Value

with the code in post #6 & and adjust the next lines
I have had a look but am struggling to fit it into my code.

If I've done it correctly, this should be a link to a modified workbook: MOT Check (Test-2).xlsm

I've removed the headings that are not part of the code and hopefully it only contains the code relevant to this bit I am trying to resolve.

Thanks for your help.
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,962
Office Version
  1. 365
Platform
  1. Windows
Try this:
VBA Code:
Sub Check()   '<<<<<<<<<<< NOT WORKING - AUTOFILTER RETURNING 4 RESULTS BUT UF ONLY HANDLES 2 BEFORE CLOSING

'Gets users username from logon details
    Dim UserName As String
        UserName = Environ("username")

'Clears any previously set filters
On Error Resume Next
Range("A1").Select
ActiveSheet.ShowAllData
On Error GoTo 0

'Sets new filters
Dim RTF As Range
Dim ColCheck As Long
Dim ColComplete As Long
Dim ColDateCheck As Long
Dim ColResult As Long

Set RTF = Worksheets("Pro").Range("Table8").Range("A1").CurrentRegion
'Filters 'Complete' column
    With RTF
        ColComplete = .Rows(1).Find(what:="Complete", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColComplete, Criteria1:="<>Yes"
'    End With
'Filters 'MOT >= Date' column
'    With RTF
        ColDateCheck = .Rows(1).Find(what:="MOT >= Date", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColDateCheck, Criteria1:="Yes"
'    End With
'Filters MOT Test Result column
'    With RTF
        ColResult = .Rows(1).Find(what:="MOT Test Result", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColResult, Criteria1:="PASSED"
'    End With
'Filters Check column
'    With RTF
        ColCheck = .Rows(1).Find(what:="Check", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColCheck, Criteria1:="Inspection"
    End With

'Pulls data for UFCheck
Dim r As Long

Dim rngColVRM As Range
Dim rngColDate As Range
Dim rngColDefect1 As Range
Dim rngColDefect2 As Range
Dim rngColDefect3 As Range
Dim rngColMOTDate As Range
Dim rngColStatus As Range
Dim rngColStatusDate As Range
Dim rngColStatusUpdate As Range
Dim rngColDateMOTChecked As Range
Dim rngColComplete As Range

With Worksheets("Pro")
    Set rngColVRM = .Range("Table8[VRM / ID]").SpecialCells(xlCellTypeVisible)
    Set rngColDate = .Range("Table8[Date]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect1 = .Range("Table8[Defect 1]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect2 = .Range("Table8[Defect 2]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect3 = .Range("Table8[Defect 3]").SpecialCells(xlCellTypeVisible)
    Set rngColMOTDate = .Range("Table8[Last MOT date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatus = .Range("Table8[Status]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusDate = .Range("Table8[Status Update Date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusUpdate = .Range("Table8[Updated by]").SpecialCells(xlCellTypeVisible)
    Set rngColDateMOTChecked = .Range("Table8[Date MOT checked]").SpecialCells(xlCellTypeVisible)
    Set rngColComplete = .Range("Table8[Complete]").SpecialCells(xlCellTypeVisible)
End With

Dim lastrow As Long
'Used to check number of responses in AutoFilter
    lastrow = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
    Debug.Print lastrow
    If lastrow < 1 Then 'Stops process if there are no entries matching criteria of AutoFilter
        '    MsgBox ("Filter empty")
        Exit Sub
    Else
            UFCheck.TxtRowNumber.Text = lastrow
    End If
   
Dim n As Long
Dim g As Range
For Each g In rngColVRM

    n = g.Row - rngColVRM.Row + 1
    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(n).Value
    .TxtDate.Text = rngColDate.Cells(n).Value
    .TxtDefect1.Text = rngColDefect1.Cells(n).Value
    .TxtDefect2.Text = rngColDefect2.Cells(n).Value
    .TxtDefect3.Text = rngColDefect3.Cells(n).Value
    .TxtMOTDate.Text = rngColMOTDate.Cells(n).Value
    
    UFCheck.Show
        If .OptClearYes.Value = True Then
            rngColStatus.Value = "Reviewed - System generated"
            rngColStatusDate.Value = Date
            rngColStatusUpdate.Value = UserName & " - System generated"
            rngColComplete.Value = "Yes"
            Worksheets("Removed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = rngColVRM.Cells(r).Value
            Worksheets("Removed").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Now
   
            .TxtVRM.Text = rngColVRM.Cells(r).Value
            .TxtDate.Text = ""
            .TxtDefect1.Text = ""
            .TxtDefect2.Text = ""
            .TxtDefect3.Text = ""
            .TxtMOTDate.Text = ""
            .OptClearNo.Value = False
            .OptClearYes.Value = False
            .TxtRowNumber.Text = .TxtRowNumber.Value - 1
        ElseIf .OptClearNo.Value = True Then
            .TxtVRM.Text = rngColVRM.Cells(r).Value
            .TxtDate.Text = ""
            .TxtDefect1.Text = ""
            .TxtDefect2.Text = ""
            .TxtDefect3.Text = ""
            .TxtMOTDate.Text = ""
            .OptClearNo.Value = False
            .OptClearYes.Value = False
            .TxtRowNumber.Text = .TxtRowNumber.Value - 1
        End If
    End With
Next
'UFCheck.Hide

End Sub

this worked in the first time, but when I tried again later "no cells found", it looks like the code changed the data so that in the next round the filter found nothing.
 

K1600

Board Regular
Joined
Oct 20, 2017
Messages
166
Try this:
VBA Code:
Sub Check()   '<<<<<<<<<<< NOT WORKING - AUTOFILTER RETURNING 4 RESULTS BUT UF ONLY HANDLES 2 BEFORE CLOSING

'Gets users username from logon details
    Dim UserName As String
        UserName = Environ("username")

'Clears any previously set filters
On Error Resume Next
Range("A1").Select
ActiveSheet.ShowAllData
On Error GoTo 0

'Sets new filters
Dim RTF As Range
Dim ColCheck As Long
Dim ColComplete As Long
Dim ColDateCheck As Long
Dim ColResult As Long

Set RTF = Worksheets("Pro").Range("Table8").Range("A1").CurrentRegion
'Filters 'Complete' column
    With RTF
        ColComplete = .Rows(1).Find(what:="Complete", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColComplete, Criteria1:="<>Yes"
'    End With
'Filters 'MOT >= Date' column
'    With RTF
        ColDateCheck = .Rows(1).Find(what:="MOT >= Date", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColDateCheck, Criteria1:="Yes"
'    End With
'Filters MOT Test Result column
'    With RTF
        ColResult = .Rows(1).Find(what:="MOT Test Result", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColResult, Criteria1:="PASSED"
'    End With
'Filters Check column
'    With RTF
        ColCheck = .Rows(1).Find(what:="Check", LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext).Column - .Column + 1
        .AutoFilter Field:=ColCheck, Criteria1:="Inspection"
    End With

'Pulls data for UFCheck
Dim r As Long

Dim rngColVRM As Range
Dim rngColDate As Range
Dim rngColDefect1 As Range
Dim rngColDefect2 As Range
Dim rngColDefect3 As Range
Dim rngColMOTDate As Range
Dim rngColStatus As Range
Dim rngColStatusDate As Range
Dim rngColStatusUpdate As Range
Dim rngColDateMOTChecked As Range
Dim rngColComplete As Range

With Worksheets("Pro")
    Set rngColVRM = .Range("Table8[VRM / ID]").SpecialCells(xlCellTypeVisible)
    Set rngColDate = .Range("Table8[Date]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect1 = .Range("Table8[Defect 1]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect2 = .Range("Table8[Defect 2]").SpecialCells(xlCellTypeVisible)
    Set rngColDefect3 = .Range("Table8[Defect 3]").SpecialCells(xlCellTypeVisible)
    Set rngColMOTDate = .Range("Table8[Last MOT date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatus = .Range("Table8[Status]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusDate = .Range("Table8[Status Update Date]").SpecialCells(xlCellTypeVisible)
    Set rngColStatusUpdate = .Range("Table8[Updated by]").SpecialCells(xlCellTypeVisible)
    Set rngColDateMOTChecked = .Range("Table8[Date MOT checked]").SpecialCells(xlCellTypeVisible)
    Set rngColComplete = .Range("Table8[Complete]").SpecialCells(xlCellTypeVisible)
End With

Dim lastrow As Long
'Used to check number of responses in AutoFilter
    lastrow = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
    Debug.Print lastrow
    If lastrow < 1 Then 'Stops process if there are no entries matching criteria of AutoFilter
        '    MsgBox ("Filter empty")
        Exit Sub
    Else
            UFCheck.TxtRowNumber.Text = lastrow
    End If
  
Dim n As Long
Dim g As Range
For Each g In rngColVRM

    n = g.Row - rngColVRM.Row + 1
    With UFCheck
    .TxtVRM.Text = rngColVRM.Cells(n).Value
    .TxtDate.Text = rngColDate.Cells(n).Value
    .TxtDefect1.Text = rngColDefect1.Cells(n).Value
    .TxtDefect2.Text = rngColDefect2.Cells(n).Value
    .TxtDefect3.Text = rngColDefect3.Cells(n).Value
    .TxtMOTDate.Text = rngColMOTDate.Cells(n).Value
   
    UFCheck.Show
        If .OptClearYes.Value = True Then
            rngColStatus.Value = "Reviewed - System generated"
            rngColStatusDate.Value = Date
            rngColStatusUpdate.Value = UserName & " - System generated"
            rngColComplete.Value = "Yes"
            Worksheets("Removed").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = rngColVRM.Cells(r).Value
            Worksheets("Removed").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = Now
  
            .TxtVRM.Text = rngColVRM.Cells(r).Value
            .TxtDate.Text = ""
            .TxtDefect1.Text = ""
            .TxtDefect2.Text = ""
            .TxtDefect3.Text = ""
            .TxtMOTDate.Text = ""
            .OptClearNo.Value = False
            .OptClearYes.Value = False
            .TxtRowNumber.Text = .TxtRowNumber.Value - 1
        ElseIf .OptClearNo.Value = True Then
            .TxtVRM.Text = rngColVRM.Cells(r).Value
            .TxtDate.Text = ""
            .TxtDefect1.Text = ""
            .TxtDefect2.Text = ""
            .TxtDefect3.Text = ""
            .TxtMOTDate.Text = ""
            .OptClearNo.Value = False
            .OptClearYes.Value = False
            .TxtRowNumber.Text = .TxtRowNumber.Value - 1
        End If
    End With
Next
'UFCheck.Hide

End Sub

this worked in the first time, but when I tried again later "no cells found", it looks like the code changed the data so that in the next round the filter found nothing.
That's sort of worked. It now loops through all the filtered rows and if the radio button 'No' is pressed, all is good. However, if the 'Yes' is pressed, it should take the VRM from that row and add it to column 'A' in the 'Removed' sheet and then add a date/time stamp to column 'B' alongside it, as well as updating the columns in appropriate columns in the current row on the 'Pro' spreadsheet. What it is actually doing is taking the VRM from one of the hidden rows (row 10) and putting that in and then in the 'Pro' sheet it completes the relevant columns but does this for all 4 of the displayed rows rather than just the current row. If that makes any sense?

To ease identifying if the correct data is being dragged across I have added a consecutive number in ()'s to the end of each VRM.

To reset the original data you just need to clear columns P to S and AK but only on the filtered rows.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,803
Messages
5,626,990
Members
416,213
Latest member
neflerine

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
Top