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

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
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

K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
188
Alex Blakenburg
A
K
  • Solved
My VBA is only copying the last row of data instead of all the rows
2 3
Replies
24
Views
606
Alex Blakenburg
A
T
  • Question
Complex VBA to loop through each worksheet and extract text
Replies
3
Views
213
bobsan42
bobsan42
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
384
Alex Blakenburg
A
E
  • Question
Estimating Spreadsheet-Summing
Replies
1
Views
169
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,215,692
Messages
6,126,227
Members
449,303
Latest member
grantrob

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