Lol. Nothing to worry about. I have a habit of posting something and then proofreading it after. I need to stop doing that. When I posted that code I saw that I had wrote something incorrectly so I went to fix and made a typo. Pretty Funny.
Pasted below is the new code that will do the same thing but allow you to write a vlookup for the duplicates using the team initials. You will need to see what it looks like after the script runs but other than that it should be the very same.
Let me know if you have any other questions.
Code:
Option Explicit
Sub PlayerRaterParser()
'Extracts the data from a set of webpages and exports the data out
Dim ie As Object, NameText As Object, NameDesText As Object
Dim TableText As Object, v As Variant, LastRow As Long, x As Integer
Dim rw As Long, Col As Long, LastCol As Long, DsExists As Boolean
Dim DuplicateCheck As Long, DuplicateIssue As Boolean, DupString As String
Dim CheckString As String, NewString As String, UrlArray(0 To 15) As String
Dim StartRow As Long, Complete As String, GiveFormula As Boolean
Dim wb As Workbook, ws As Worksheet, rws As Worksheet, uws As Worksheet
GiveFormula = True
Set wb = ThisWorkbook
'Make sure the scrape sheet exists
Application.DisplayAlerts = False
For Each v In wb.Worksheets
If v.Name = "Data Scrape" Then
v.Range("A1:O1000").ClearContents
v.Range("A1:O1000").ClearFormats
v.Range("1:2").Font.Bold = True
DsExists = True
End If
Next v
If DsExists = False Then
Sheets.Add
ActiveSheet.Name = "Data Scrape"
End If
Set ws = wb.Worksheets("Data Scrape")
ws.Range("1:2").Font.Bold = True
ws.Activate
UrlArray(0) = "http://games.espn.go.com/flb/playerrater"
UrlArray(1) = "http://games.espn.go.com/flb/playerrater?startIndex=50"
UrlArray(2) = "http://games.espn.go.com/flb/playerrater?startIndex=100"
UrlArray(3) = "http://games.espn.go.com/flb/playerrater?startIndex=150"
UrlArray(4) = "http://games.espn.go.com/flb/playerrater?startIndex=200"
UrlArray(5) = "http://games.espn.go.com/flb/playerrater?startIndex=250"
UrlArray(6) = "http://games.espn.go.com/flb/playerrater?startIndex=300"
UrlArray(7) = "http://games.espn.go.com/flb/playerrater?startIndex=350"
UrlArray(8) = "http://games.espn.go.com/flb/playerrater?startIndex=400"
UrlArray(9) = "http://games.espn.go.com/flb/playerrater?startIndex=450"
UrlArray(10) = "http://games.espn.go.com/flb/playerrater?startIndex=500"
UrlArray(11) = "http://games.espn.go.com/flb/playerrater?startIndex=550"
UrlArray(12) = "http://games.espn.go.com/flb/playerrater?startIndex=600"
UrlArray(13) = "http://games.espn.go.com/flb/playerrater?startIndex=650"
UrlArray(14) = "http://games.espn.go.com/flb/playerrater?startIndex=700"
UrlArray(15) = "http://games.espn.go.com/flb/playerrater?startIndex=750"
'Create the IE object to use
Set ie = CreateObject("InternetExplorer.application")
ie.Visible = True
For x = 0 To 15
StartRow = ws.Range("A50000").End(xlUp).Row + 1
ie.Navigate UrlArray(x)
Do While ie.ReadyState <> 4 'Make sure page loads
DoEvents
Loop
'grab the needed HTML
Set NameText = ie.Document.GetElementsByClassName("flexpop")
Set NameDesText = ie.Document.GetElementsByClassName("playertablePlayerName")
Set TableText = ie.Document.GetElementsByClassName("playertableData")
rw = StartRow + 1
ws.Range("A" & StartRow).Select
For Each v In NameText
ws.Range("A" & rw).Value = v.innertext
If v.innertext <> "" Then
rw = rw + 1
End If
Next v
rw = StartRow + 1
For Each v In NameDesText
If v.innertext <> "" Then
ws.Range("B" & rw).Value = Replace(v.innertext, ws.Range("A" & rw).Value & ", ", "")
rw = rw + 1
End If
Next v
'Fill in the table data
LastCol = 15
Col = 4
rw = StartRow
For Each v In TableText
ws.Cells(rw, Col).Value = v.innertext
If Col = LastCol Then
Col = 4
rw = rw + 1
Else
Col = Col + 1
End If
Next v
Next x
'All data scraped
'Clean up
ie.Quit
Set ie = Nothing
'Create a LookupString
LastRow = ws.Range("A50000").End(xlUp).Row
ws.Range("C:C").Font.ColorIndex = 5
'Clear out the extra headers
ws.Range("A1").EntireRow.Delete
For rw = 2 To LastRow
ws.Range("C" & rw).Select
If ws.Range("D" & rw).Value = "RNK" Then
ws.Range("D" & rw).EntireRow.Delete
rw = rw - 1
End If
Next rw
ws.Range("A1").Value = "Player Name"
ws.Range("B1").Value = "Team POS"
ws.Range("C1").Value = "LookupString"
LastRow = ws.Range("A50000").End(xlUp).Row
'Remove the space
For rw = 2 To LastRow
CheckString = ws.Range("A" & rw).Value
NewString = Mid(CheckString, InStr(1, CheckString, " ") + 1)
NewString = NewString & Mid(CheckString, 1, InStr(1, CheckString, " ") - 1)
ws.Range("C" & rw).Value = NewString
Next rw
'Check for any duplicates
For rw = 2 To LastRow
DuplicateCheck = WorksheetFunction.CountIf(ws.Range("C:C"), ws.Range("C" & rw).Value)
If DuplicateCheck > 1 Then
DupString = DupString & "Row " & rw & ", "
ws.Range("A" & rw & ":C" & rw).Interior.Color = vbRed
End If
Next rw
'Create new names
For rw = 2 To LastRow
If ws.Range("C" & rw).Interior.Color = vbRed Then
ws.Range("C" & rw).Value = ws.Range("C" & rw).Value & "_" & ws.Range("B" & rw).Value
End If
Next rw
ws.Range("A1").Select
If DupString <> "" Then
MsgBox "You have duplicates on the following row(s): " & DupString & vbLf & _
"These cells have been highlighted red and the name has been changed." & vbLf & _
"These will not lookup and will need to be entered manually."
End If
If GiveFormula = True Then
Complete = InputBox("Please copy and paste this formula into your worksheet now.", _
Default:="=VLOOKUP(A4&B4,'Data Scrape'!C:O,13,0)")
End If
End Sub