View Single Post
 
Old 08-23-2014, 02:36 PM
excelledsoftware excelledsoftware is offline Windows 7 64bit Office 2003
IT Specialist
 
Join Date: Jan 2012
Location: Utah
Posts: 455
excelledsoftware will become famous soon enough
Default

Done. I was feeling really nice. This script will do the following:
It will automatically open up the webpage and put that data into a worksheet. This worksheet will be formatted in a way that will allow you to use a vlookup on your first sheet by just putting the 2 names together. If you have more than 1 URL to do let me know and I will make a small change to the code that will allow you to do as many URLs as you like without ever having to copy and paste the data.

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
  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
  Dim wb As Workbook, ws As Worksheet, rws As Worksheet, uws As Worksheet
  
    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("A:Z").ClearContents
          v.Range("1:1").Font.Bold = True
          DsExists = True
        End If
      Next v
    Application.DisplayAlerts = True
    
      If DsExists = False Then
        Sheets.Add
        ActiveSheet.Name = "Data Scrape"
      End If
      
    Set ws = wb.Worksheets("Data Scrape")
    ws.Activate
    'Create the IE object to use
    Set ie = CreateObject("InternetExplorer.application")
    ie.Visible = True
    
    ie.Navigate "http://games.espn.go.com/flb/playerrater"
      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 = 2
      For Each v In NameText
        ws.Range("A" & rw).Value = v.innertext
        If v.innertext <> "" Then
          rw = rw + 1
       End If
      Next v
    rw = 2
      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 = 1
    
      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
            
    ws.Range("A1").Value = "Player Name"
    ws.Range("B1").Value = "Team POS"
            
      'Clean up
      ie.Quit
      Set ie = Nothing
      
    'Create a LookupString
      LastRow = ws.Range("A50000").End(xlUp).Row
      
      ws.Range("C:C").Font.ColorIndex = 5
      ws.Range("C1").Value = "LookupString"
      
    '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
        End If
      Next rw
      
      If DupString <> "" Then
        MsgBox "You have duplicates on the following row(s): " & DupString & vbLf & _
        "Your Vlookup will not work unless you change these values"
      End If

End Sub
Thanks

Last edited by excelledsoftware; 08-23-2014 at 02:38 PM. Reason: forgot some WS objects
Reply With Quote