Extracting data via Do Until loops and Nested Ifs vs Autofilter.. Reliability?

RockandGrohl

Well-known Member
Joined
Aug 1, 2018
Messages
788
Office Version
  1. 2010
Platform
  1. Windows
Hi all,

I'm looking to replace a legacy system to select adverts from a database which uses some pretty beefy VBA code with a new system that uses criteria to take the information from the same database.

My question is whether autofilters are a good idea or if there's an inherent fault with them which results in unreliability etc.

As an example, if we had an advert in the Worcester Advertiser Newspaper which picks up in Worcester, Droitwich, Bromsgrove, Pershore then the paper information would be held as a variable, the database opened and there would be various loops down the 28,000 rows on this datbase, for example:

If criteria X, Y and Z are selected, then loop down until I find a row in the database >= "tdate" then from there check if the pickups for the tour match the paper, check this matches that, check this, etc etc.

Alternatively, I'm thinking of a radical new solution which just uses filters to prevent Excel wasting resources by continually looping and resetting and looping and resetting. I realise that for Excel to loop down a column checking one criteria is extremely fast - we're doing 1,000's of rows per second on these machines, but the code behind it is over 180 lines long and it's impossible to debug any errors.

From stepping through, it seems like it really does just boil down to loop down and check for this, loop down and check for that, which is so much easier to read and write with autofilter, the criteria can be easily adjusted and you can read over the lines and actually parse it.

Seriously, 180 lines to do one function, and the rows are all nested within each other, so it just stretches down and across the VBE. I reckon I could do the same function in about 30-40 lines max!

As long as there isn't a problem with autofilter, of course.
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
I can't really fathom why looping through rows and checking criteria would take 180 lines, however you do it.
 
Upvote 0
I can't really fathom why looping through rows and checking criteria would take 180 lines, however you do it.

I've way oversimplified it, but that's the core of what's happening.

We do various types of tours, Coach, Rail, Flight and Self Drive, so there's different variations of looping depending on what's required, also two halves of the company which can't mix, so two different types of loops there.

Things like that can easily be solved with initial filters, like if "Company A = True then filter to this, else, filter to that"

Wanna see the code? You asked for it, you got it..


Code:
For y = x To 75Tourno = ""
    Do Until (AdSelect.CompList.Value = "Omega" And Cells(ActiveCell.Row, "J").Value Like "*Omega*") Or (AdSelect.CompList.Value = "Just Go" And Not Cells(ActiveCell.Row, "J").Value Like "*Omega*") Or AdSelect.CompList.Value = "" Or Cells(ActiveCell.Row, "A").Value = ""
    ActiveCell.Offset(1, 0).Activate
    Loop
    If durrest = True And Cells(ActiveCell.Row, "F").Value <> durlim Then
    GoTo JumpNext
    End If
    If Cells(ActiveCell.Row, "E").Value >= tdate And Cells(ActiveCell.Row, "B").Value = "Active" And Cells(ActiveCell.Row, "I").Value <> "Not Routed" Then
        If (", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU1 & ",*" Or ", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU2 & ",*" Or ", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU3 & ",*" Or ", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU4 & ",*" Or ", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU5 & ",*" Or ", " & Cells(ActiveCell.Row, "I").Value & "," Like "*, " & PPU6 & ",*") Or (ttype = "rs" And Cells(ActiveCell.Row, "I").Value Like "Train to*") Then
            If (Left(Cells(ActiveCell.Row, "A").Value, 1) = 3 And ExtCount <= CInt(AdSelect.ExtMaxBox.Text)) Or Left(Cells(ActiveCell.Row, "A").Value, 1) <> 3 Then
            ttc = 0
                For tt = 1 To 75
                    If AdSelect.Controls("Frame" & tt).Visible = True Then
                    tnamett = AdSelect.Controls("TDet" & tt).Caption
                    On Error Resume Next
                    tnamett = Left(tnamett, InStr(tnamett, " • ") - 2)
                    On Error GoTo 0
                        If Cells(ActiveCell.Row, "C").Value = tnamett Then
                        ttc = ttc + 1
                        End If
                    End If
                Next tt
                If (ttc < 5 And AdSelect.CapFlag.Value = True) Or AdSelect.CapFlag.Value = False Then
                'Theatre handling
                    If (Cells(ActiveCell.Row, "X").Value = "Y" And th = False) Or Cells(ActiveCell.Row, "X") = "N" And th = True Then
                    GoTo JumpNext
                    End If
                Tourno = Cells(ActiveCell.Row, "A").Value
                'Check tour has not already been selected, and jump onwards if it has
                temp.Activate
                Range("B1").Activate
                    Do Until Cells(ActiveCell.Row, "B").Value = ""
                        If Cells(ActiveCell.Row, "B").Value = CStr(Tourno) Then
                        ads.Activate
                        GoTo JumpNext
                        End If
                    ActiveCell.Offset(1, 0).Activate
                    Loop
                ads.Activate
                    If Left(Tourno, 1) = 3 Then
                    ExtCount = ExtCount + 1
                    End If
                    If Left(Tourno, 1) = "L" Then
                    AdSelect.Controls("JGRTPrice" & y).Text = Format(Cells(ActiveCell.Row, "G").Value, "#,##0.00")
                    Else
                    MinDisc = ""
                        Do Until CStr(Cells(ActiveCell.Offset(1, 0).Row, "A").Value) <> Tourno
                            If Cells(ActiveCell.Row, "H").Value <> "" And (Cells(ActiveCell.Row, "H").Value < MinDisc Or MinDisc = "") Then
                            MinDisc = Cells(ActiveCell.Row, "H").Value
                            End If
                        ActiveCell.Offset(1, 0).Activate
                        Loop
                        If MinDisc <> "" Then
                        AdSelect.Controls("JGRTPrice" & y).Text = Format(MinDisc, "#,##0.00")
                        Else
                        AdSelect.Controls("JGRTPrice" & y).Text = ""
                        End If
                    End If
                AdSelect.Controls("Frame" & y).Visible = True
                AdSelect.Controls("Tourno" & y).Caption = Cells(ActiveCell.Row, "A").Value
                AdSelect.Controls("Tourno" & y).Font.Size = 13
                tnam = Cells(ActiveCell.Row, "C").Value
                fprice = Cells(ActiveCell.Row, "G").Value
                pup = Cells(ActiveCell.Row, "I").Value
                'Railway supplement handling
                    If ttype = "rs" Then
                    rt.Activate
                    Range("A3").Activate
                        Do Until Cells(ActiveCell.Row, "A").Value = ""
                            If Cells(ActiveCell.Row, "A").Value = tnam Then
                            ta = Cells(ActiveCell.Row, "B").Value
                            Exit Do
                            End If
                        ActiveCell.Offset(1, 0).Activate
                        Loop
                        If Cells(ActiveCell.Row, "A").Value = "" Then
                        ads.Activate
                        GoTo JumpNext
                        End If
                    rs.Activate
                    Range("B2").Activate
                        Do Until Cells(2, ActiveCell.Column).Value = ""
                            If Cells(2, ActiveCell.Column).Value = ta Then
                            acol = ActiveCell.Column
                            Exit Do
                            End If
                        ActiveCell.Offset(0, 1).Activate
                        Loop
                    Range("A3").Activate
                        Do Until Cells(ActiveCell.Row, "A").Value = ""
                            If (Cells(ActiveCell.Row, "A").Value = PPU1 Or Cells(ActiveCell.Row, "A").Value = PPU2 Or Cells(ActiveCell.Row, "A").Value = PPU3 Or Cells(ActiveCell.Row, "A").Value = PPU4 Or Cells(ActiveCell.Row, "A").Value = PPU5 Or Cells(ActiveCell.Row, "A").Value = PPU6) And (Cells(ActiveCell.Row, acol).Value <> "" And Cells(ActiveCell.Row, acol).Value <> "N/A") Then
                            Exit Do
                            End If
                        ActiveCell.Offset(1, 0).Activate
                        Loop
                        If Cells(ActiveCell.Row, "A").Value <> "" Then
                        stationfail = False
                        fprice = fprice + Cells(ActiveCell.Row, acol).Value
                        pup = Cells(ActiveCell.Row, "A").Value
                        Else
                        stationfail = True
                        End If
                    ads.Activate
                        If stationfail = True Then
                        GoTo JumpNext
                        End If
                    AdSelect.Controls("JGRTPrice" & y).Text = Format(fprice, "#,##0.00")
                    End If
                AdSelect.Controls("TDet" & y).Caption = Cells(ActiveCell.Row, "C").Value & "  •  " & Cells(ActiveCell.Row, "D").Value & "  •  " & Format(Cells(ActiveCell.Row, "E").Value, "dd/mm/yyyy") & "  •  " & Cells(ActiveCell.Row, "F").Value & " Days" & "  •  " & Format(fprice, "£#,##0.00") & "  •  " & Cells(ActiveCell.Row, "K").Value & "  •  " & Cells(ActiveCell.Row, "J").Value & "  •  " & Cells(ActiveCell.Row, "Z").Value & " Rem. Pax Cap."
                AdSelect.Controls("TDet" & y).Font.Size = 7
                AdSelect.Controls("Pickups" & y).Caption = pup
                AdSelect.Controls("Pickups" & y).Font.Size = 7
                AdSelect.Controls("Skip" & y) = True
                AdSelect.Controls("PULab" & y).Visible = True
                AdSelect.Controls("PriceLabel" & y).Visible = True
                AdSelect.Controls("Skip" & y).Visible = True
                AdSelect.Controls("Feat" & y).Visible = True
                temp.Activate
                Range("E1").Value = AdSelect.Controls("Pickups" & y).Caption
                Range("D1:D" & Lastrow).FormulaR1C1 = "=IF(IFERROR(SEARCH("", ""&RC3&"","","", ""&R1C5&"","",1),0)>0,""Y"",""N"")"
                Range("C1").Activate
                TPickups = ""
                    Do Until Cells(ActiveCell.Row, "C").Value = ""
                        If Cells(ActiveCell.Row, "D").Value = "Y" Then
                            If TPickups <> "" Then
                            TPickups = TPickups & ", " & Cells(ActiveCell.Row, "C").Value
                            Else
                            TPickups = Cells(ActiveCell.Row, "C").Value
                            End If
                        End If
                    ActiveCell.Offset(1, 0).Activate
                    Loop
                AdSelect.Controls("JGRTPickups" & y).Text = TPickups
                ads.Activate
                Else
                y = y - 1
                End If
            Else
            y = y - 1
            End If
        Else
        y = y - 1
        End If
    Else
JumpNext:
    y = y - 1
    End If
    If Tourno <> "" Then
        Do Until CStr(Cells(ActiveCell.Row, "A").Value) <> Tourno
        ActiveCell.Offset(1, 0).Activate
        Loop
    Else
    ActiveCell.Offset(1, 0).Activate
    End If
    If Cells(ActiveCell.Row, "A").Value = "" Then
        If y = 0 Then
        NoTours = True
        End If
    y = 75
    Else
    On Error Resume Next
    AdSelect.Frame1.SetFocus
    On Error GoTo 0
    End If
Next y



So a lot of the code determines how the information should be represented on the adselect panel, but I'm doing away with all that, so I just need to know the applicable tours, dump all the rest and hopefully make the entire process last 0.5 seconds instead of 15.
 
Upvote 0
I feel slightly queasy reading that code. All those Gotos and cell activating...
 
Upvote 0
I feel slightly queasy reading that code. All those Gotos and cell activating...

Now imagine how I feel when the task is up to me to sort it :'D


Can you kind of understand the objective of the code? There's a whole load of input criteria, what tour type, what paper, what pickup, it needs 75 tours to pick from to let us choose 2/75 to advertise, the method of travel, etc etc etc.

And then it has to output it, chop up some strings to display parts more prominently etc.

How would you do it differently? Is Autofilter a good route to go down? I've used this method before with other, similarly large spreadsheets and it has no problem filtering to applicable criteria and copying the good stuff out.
 
Upvote 0
Do whatever works for you, is my best suggestion. Personally I'd probably use arrays, or Power Query, depending on the exact situation.
 
Upvote 0

Forum statistics

Threads
1,214,905
Messages
6,122,175
Members
449,071
Latest member
cdnMech

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