Search loop

F

fredrerik84

Active Member
Joined
Feb 26, 2017
Messages
383
Hi Ive been struggling with a search loop today

here is what I got:

Code: 
    j = 4
    x = 4
    lr = Cells(Rows.Count, "C").End(xlUp).Row


search:
    If j > lr Then
       Exit Sub
    End If
    
    Ateam = Cells(j, "Q")
    For i = 4 To lr
       If Cells(i, "C").Value = Ateam Then
          Cells(j, "V").Value = Cells(i, "F")
          j = j + 1
          GoTo search
       End If
    Next i

Basically column Q have names stored and the same names are stored in column C
Im trying to search trough the names i column Q and find values that are stored in column F.

This code I have created works as long as there is no errors Ive tried to add some error handling to make it jump over search crteria that is not fund but so far no luck :/

Any help to fix or make this code faster would be greatly appreciated :)
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Shouldn't this simply be

Code: 
   j = 4
    x = 4
    lr = Cells(Rows.Count, "C").End(xlUp).Row

search:
    Ateam = Cells(j, "Q")
    For i = 4 To lr
       If Cells(i, "C").Value = Ateam Then
          Cells(j, "V").Value = Cells(i, "F")
          j = j + 1
       End If
    Next i
 
Upvote 0
fredrerik84 said:
Hi Ive been struggling with a search loop today

here is what I got:

Code: 
    j = 4
    x = 4
    lr = Cells(Rows.Count, "C").End(xlUp).Row


search:
    If j > lr Then
       Exit Sub
    End If
    
    Ateam = Cells(j, "Q")
    For i = 4 To lr
       If Cells(i, "C").Value = Ateam Then
          Cells(j, "V").Value = Cells(i, "F")
          j = j + 1
          GoTo search
       End If
    Next i

Basically column Q have names stored and the same names are stored in column C
Im trying to search trough the names i column Q and find values that are stored in column F.

This code I have created works as long as there is no errors Ive tried to add some error handling to make it jump over search crteria that is not fund but so far no luck :/

Any help to fix or make this code faster would be greatly appreciated :)
Click to expand...

Frederick,

I'm trying to follow exactly what you're trying to accomplish. Are you trying to iterate through each value in column Q, find that value in column C, return the corresponding value in column F, and store it in column V (same row as the "Q" search term)?
 
Upvote 0
What you have here is a loop in loop so I don't understand why you use GOTO. To say the true, it's better when we don't use any goto statement.

This would be a better alternative
Code: 
    x = 4
    lr = Cells(Rows.Count, "C").End(xlUp).Row


If lr < 4 Then
    Exit Sub
End If


For j = 4 To lr
    Ateam = Cells(j, "Q")
    For i = 4 To lr
       If Cells(i, "C").Value = Ateam Then
          Cells(j, "V").Value = Cells(i, "F")
          Exit For
       End If
    Next i
Next
 
Upvote 0
MrKowz said:
Frederick,

I'm trying to follow exactly what you're trying to accomplish. Are you trying to iterate through each value in column Q, find that value in column C, return the corresponding value in column F, and store it in column V (same row as the "Q" search term)?
Click to expand...

If, in fact, this is what you're trying to accomplish, give this a shot.

Code: 
Public Sub SearchLoop()
Dim LR      As Long, _
    i       As Long

Dim rng     As Range
    
Dim ateam   As String

    
LR = Cells(Rows.Count, "Q").End(xlUp).Row

For i = 2 To LR
    ateam = Range("Q" & i).Value
    With Range("C:C")
        Set rng = .Find(ateam, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Range("V" & i).Value = rng.Offset(0, 3).Value
        End If
        Set rng = Nothing
    End With
Next i

End Sub
 
Upvote 0
MrKowz said:
If, in fact, this is what you're trying to accomplish, give this a shot.

Code: 
Public Sub SearchLoop()
Dim LR      As Long, _
    i       As Long

Dim rng     As Range
    
Dim ateam   As String

    
LR = Cells(Rows.Count, "Q").End(xlUp).Row

For i = 2 To LR
    ateam = Range("Q" & i).Value
    With Range("C:C")
        Set rng = .Find(ateam, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Range("V" & i).Value = rng.Offset(0, 3).Value
        End If
        Set rng = Nothing
    End With
Next i

End Sub
Click to expand...
Here is a way to simplify your loop...
Code: 
[table="width: 500"]
[tr]
	[td]Public Sub SearchLoop()
  Dim Rw As Long, LR As Long
  LR = Cells(Rows.Count, "Q").End(xlUp).Row
  For Rw = 2 To LR
    Cells(Rw, "V").Value = Evaluate("VLOOKUP(Q" & Rw & ",C:F,4,FALSE)")
  Next i
End Sub[/td]
[/tr]
[/table]
 
Upvote 0
Thanks for all your replies ., Of course my script crashed here :/
for some reason excel refuses to accept this line:

Code: 
Set Doc = IE.document

Need to figure out whats gone wrong before I can test all your great suggestions:)
 
Upvote 0
here is my entire code:

Code: 
Option Explicit
Sub mars()


  Dim shellWins As ShellWindows
  Dim IE As New SHDocVw.InternetExplorer
  Dim Doc As New MSHTML.HTMLDocument
  Dim HTMLRows As MSHTML.IHTMLElementCollection
  Dim HTMLRows2 As MSHTML.IHTMLElementCollection
  Dim URL As String
  Dim j As Long, i As Long, x As Long, lr As Long
  Dim mars As String
  Set shellWins = New ShellWindows
  Dim hteam As String
  Dim Ateam As String


  If shellWins.Count > 0 Then
    ' Get IE
    Set IE = shellWins.Item(0)
    GoTo fetchodds
  Else
    ' Create IE
    IE.Visible = True
    URL = "http://www.marsbet.se/#/sport/?type=0&competition=566&sport=1&region=20001&game=7401507"
    Application.Wait (Now + TimeValue("0:00:12"))
    IE.Navigate URL
  End If




fetchodds:
    Range("C" & 54 & ":C" & 4650).Value = ""
    Set Doc = IE.document
    Set HTMLRows = Doc.getElementsByClassName("events-list-view-v3")
    Set HTMLRows2 = Doc.getElementsByClassName("mini-title-box-gameview-v3")
    
    Columns("C").NumberFormat = "@"
     j = 4
     x = 17
     For i = 0 To HTMLRows2.Length - 1
        hteam = Trim(Split(HTMLRows(i).innerText, vbCrLf)(7))
        Ateam = Trim(Split(HTMLRows(i).innerText, vbCrLf)(25))
        Ateam = Replace(Ateam, "FC BATE Borisov", "BATE Borisov")
        hteam = Replace(hteam, "FC BATE Borisov", "BATE Borisov")
        Ateam = Replace(Ateam, "SK Slavia Praha", "Slavia Praha")
        hteam = Replace(hteam, "SK Slavia Praha", "Slavia Praha")
        Ateam = Replace(Ateam, "FC Viitorul Constanta", "Viitorul Constanta")
        hteam = Replace(hteam, "FC Viitorul Constanta", "Viitorul Constanta")
        Ateam = Replace(Ateam, "Slavia Praha", "Slavia Prague")
        hteam = Replace(hteam, "Slavia Praha", "Slavia Prague")
        Ateam = Replace(Ateam, "FK Vardar", "Vardar Skopje")
        hteam = Replace(hteam, "FK Vardar", "Vardar Skopje")
        Ateam = Replace(Ateam, "FH Hafnarfjordur", "Hafnarfjordur")
        hteam = Replace(hteam, "FH Hafnarfjordur", "Hafnarfjordur")
        Ateam = Replace(Ateam, "Ajax Amsterdam", "Ajax")
        hteam = Replace(hteam, "Ajax Amsterdam", "Ajax")
        Ateam = Replace(Ateam, "PFC Ludogorets Razgrad", "Ludogorets")
        hteam = Replace(hteam, "PFC Ludogorets Razgrad", "Ludogorets")
        Ateam = Replace(Ateam, "HNK Rijeka", "Rijeka")
        hteam = Replace(hteam, "HNK Rijeka", "Rijeka")
        Ateam = Replace(Ateam, "Celtic FC", "Celtic")
        hteam = Replace(hteam, "Celtic FC", "Celtic")
        Ateam = Replace(Ateam, "Olympiacos Piraeus", "Olympiakos")
        hteam = Replace(hteam, "Olympiacos Piraeus", "Olympiakos")
        Ateam = Replace(Ateam, "Istanbul Basaksehir", "Basaksehir")
        hteam = Replace(hteam, "Istanbul Basaksehir", "Basaksehir")
        Ateam = Replace(Ateam, "BSC Young Boys", "Young Boys")
        hteam = Replace(hteam, "BSC Young Boys", "Young Boys")
        Ateam = Replace(Ateam, "FC Viktoria Plzen", "Plzen")
        hteam = Replace(hteam, "FC Viktoria Plzen", "Plzen")
        
        Cells(j, x).Value = hteam
        Cells(j, x + 2).Value = Trim(Split(HTMLRows(i).innerText, vbCrLf)(8))
        Cells(j, x + 3).Value = Trim(Split(HTMLRows(i).innerText, vbCrLf)(17))


        Cells(j, x + 1).Value = Ateam
        Cells(j, x + 4).Value = Trim(Split(HTMLRows(i).innerText, vbCrLf)(26))
        On Error Resume Next
        j = j + 1
    Next i
    
    j = 4
    x = 4
    lr = Cells(Rows.Count, "C").End(xlUp).Row


search:
    If j >= lr Then
       Exit Sub
    End If
    
    Ateam = Cells(j, "Q")
    For i = 4 To lr
       If Cells(i, "C").Value = Ateam Then
          Cells(j, "V").Value = Cells(i, "F")
          j = j + 1
          GoTo search
       End If
    Next i
    
  Set shellWins = Nothing
  Set IE = Nothing
    
    End Sub

But now it refuses to set the doc :(
 
Upvote 0
finally fixed it :)

@ Rick Rothstein I was actually planning on using your suggested solution in the end I ended up using it like this :

Code: 
Sub testmrexcel()
Dim LR      As Long, _
    i       As Long


Dim rng     As Range
    
Dim ateam   As String


    
LR = Cells(Rows.Count, "Q").End(xlUp).Row


For i = 2 To LR
    ateam = Range("Q" & i).Value
    With Range("C:C")
        Set rng = .Find(ateam, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            Range("V" & i).Value = rng.Offset(0, 3).Value
        End If
        Set rng = Nothing
    End With
Next i


End Sub

Its lightning fast compared to what i tried :)

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

Similar threads

S
  • Solved
Find and replace multiple values with other values in a range
Replies
8
Views
431
Rick Rothstein
Rick Rothstein
K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
532
Alex Blakenburg
A
B
  • Question Question
Excel VBA Searching Unique Variables to Match against Exported Schedule Files to Determine Date
Replies
1
Views
158
sijpie
sijpie
J
  • Question Question
VBA Search box and button code
Replies
0
Views
247
jlcodes
J
K
  • Solved
My VBA is only copying the last row of data instead of all the rows
2 3
Replies
24
Views
1K
Alex Blakenburg
A

Forum statistics

Threads
1,223,910
Messages
6,175,316
Members
452,634
Latest member
cpostell

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