#16
|
|||
|
|||
Ok thanks again
I entered the duplicate names manually and rerun the script, and it updated it in sheet 1. Also it said i had a error 438 in the script, it was highlighted it was in the (v.Range("A1:O1000").ClearFomats), i just guessed that it was the fomats needed to be formats, and i changed it then i could re run the script. I Got Lucky i guess, lol Thanks Rog |
#17
|
|||
|
|||
Oh man that's a super embarrassing typo.
Yes that is what needed to be done. Good job. I will get the updated script to you as soon As I am done with work. |
#18
|
|||
|
|||
I Didn't mean for it to be embarassing to you, sorry, i just wanted you to know what i did, in case it was wrong.
Rog |
#19
|
|||
|
|||
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 |
#20
|
|||
|
|||
Ok thanks again
1 - I have installed the new Script, but i am not sure where the vlookup should be put at, and how, with the script, so that is one question? 2 - Is there a way in the script to change the #na that is showing up in the rows where players name don't have updates to their Player Value Column, maybe a $0.00 instead of the #na? 3 - Ok after all of this done, can the shape i created have to stay on sheet 1, or can I just add a shape whenever i run the script again? 4 - Also when the script is already ran and updated sheet 1, do i need to keep the datascrape sheet, and if i do, does it have to be in front of sheet 1 on the tabs below? I know these questions are probably senseless, but i just want to clairfy what i can do and what i can't with the sheets, now with VBA scripts. 5 - And finally i just want to thank you for your time and what you do to help others out with these functions, your are truly Appreciated. Thanks Rog |
#21
|
|||
|
|||
Hi Rogcar,
I will address each of these concerns. 1. the vlookup should stay in your first worksheet. You mentioned that you corrected the formula to work so you can use that same formula. The different part is if you get a #N/A from the lookup you can change just that lookup to include the team name as well. You will need to look at the red highlighted names to see what it changed the SearchString into. 2.Yes that is possible. You just need to change your formula to have IfError( in front of it. I believe the formula would be Code:
=IfError(VLOOKUP(A4&B4,'Data Scrape'!C:O,13,0),0.00) 4.The script will automatically create the DataScrape sheet if it is not there. However if you choose to delete while you have your vlookup formulas on your first sheet you will get a #REF error and will need to rewrite the formulas when the DataScrape Sheet is recreated. It does not matter where in the workbook the DataScrape sheet is you can move it to the end or do what you wish with it. 5.What a nice note. I appreciate the questions. I have a project for work coming up that needs this same type of coding so this is really good practice for me. Thank you for the kind words. |
#22
|
|||
|
|||
Ok, Thank You
One more question and i will quit asking questions, lol I am still not sure where the vlookup goes for the Duplicates. 1 - Does it go in the Player Value formula, or create a formula for the team column, or where, and what should it include in the formula? The search string is this: YoungChris_Sea SP Thanks again for your time. |
#23
|
|||
|
|||
No problem ask away.
so you would change the vlookup on your first sheet to include all of the searchstring. Based off of the example you provided the formula would be something like Code:
=VLOOKUP(A9&B9&"_"&E9&" "&F9,'Data Scrape'!C:O,13,0) Thanks |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Newbie to excel for starters, needing to transfer info from sheet2 to universe sheet. | rogcar75 | Excel | 0 | 08-12-2014 07:21 AM |
How to populate cells in Sheet2 with Data Source query using cell data from Sheet1 | bobznkazoo | Excel | 2 | 03-27-2014 11:14 AM |
split text files to worksheets (sheet1,sheet2,sheet3 soon sheet 25) | gsrikanth | Excel Programming | 1 | 03-22-2012 11:04 PM |
arrows remain between task bars, but predecessor info disappears from task info | Antares | Project | 1 | 12-14-2011 09:19 AM |
How to merge two cells from sheet1 to one cell in sheet2 in next sheet | KIM SOLIS | Excel | 6 | 10-30-2011 11:14 PM |