Paste address list from website to Excel

[caunyd]

Hi guys. I am trying cut and paste a list into Excel, and have Excel separate the different fields for me. There are 12 lines per each entry on the list. I use Firefox as my browser, and when I cut and paste using Firefox into Excel, this is how it looks:

James H. Patel, MD
(space)
Pediatrician
(space)
14642 Newport Ave Ste 450
Tustin, CA 92780
(space)
(space)
30 Years Experience
1 Office Location
30 Insurance Carriers
(space)
Mark P. Smith, DO
Etc.
Etc.

I’m hoping for the final product to look like this:
Last Name----First Name----whether MD or DO----Street Address----City, State, Zip code----Zipcode(by itself)

The website that I’m copying and pasting from is: http://doctor.webmd.com/results?city...ame=Pediatrics

Any help would be much appreciated because I don’t know what I’m doing and I’ve been coming up with garbage like:
=LEFT(INDEX($A:$A,(ROW()-1)*4-2),FIND(",",INDEX($A:$A,(ROW()-1)*4-2))-1)

[natefarm]

1. In your workbook, create a sheet called WebMD, and add your column headings.
2. Insert a code module and paste the code below into it.
3. On the Developer tab, click Macros, select PasteWebMD, and click Options.
4. For the Shortcut key, enter p (for Paste), and click Ok and Cancel.
5. Save the workbook as a .xlsm (macro-enabled)

The above is one-time only and sets up the functionality. Then ...

1. On the web page, go to the 1st page.
2. Press Ctrl-A (Select All) and Ctrl-C (Copy).
3. Flip over to the WebMD workbook and press Ctrl-P.
4. Go back to the browser, select the next page, and repeat steps 2 & 3.
5. Continue until you have all the pages.

To avoid needing the mouse, use Alt-Tab to flip back & forth.

You may need to make adjustments if you come across odd names or other issues, but this worked for the 1st 5 pages or so.

Maybe there's a better way to grab a full table out of a web site, but this is the only way I know how to do it.

Option Explicit
Dim PRow As Long, EndRow As Long, MDRow As Long, Txt As String, Pos As Long
Sub PasteWebMD()

    Application.ScreenUpdating = False
    Sheets.Add
    ActiveSheet.Paste
    On Error Resume Next
    Cells.Find(what:="Showing ").Select
    On Error GoTo 0
    If ActiveCell.Address = "$A$1" Then
        MsgBox """Showing"" text not found."
        Exit Sub
    End If
    
    PRow = ActiveCell.Row + 2
    EndRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("WebMD")
        MDRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Do Until PRow > EndRow Or IsNumeric(Cells(PRow, 1).Value)
            Txt = Cells(PRow, 1).Value
            Pos = InStr(Txt, ",")
            If Pos > 0 Then
                .Cells(MDRow, 3).Value = Right(Txt, Len(Txt) - Pos) ' Type
                Txt = Left(Txt, Pos - 1)
            End If
            Pos = InStr(Txt, ".")
            If Pos = 0 Then
                Pos = InStr(Txt, " ")
            End If
            .Cells(MDRow, 1).Value = Right(Txt, Len(Txt) - Pos) ' Last Name
            .Cells(MDRow, 2).Value = Left(Txt, Pos - 1) ' 1st Name
            .Cells(MDRow, 4).Value = Cells(PRow + 4, 1).Value ' Address
            Txt = Cells(PRow + 5, 1).Value
            .Cells(MDRow, 5).Value = Txt ' City, St, Zip
            Pos = InStrRev(Txt, " ")
            .Cells(MDRow, 6).Value = Right(Txt, Len(Txt) - Pos) ' Zip
            
            MDRow = MDRow + 1
            PRow = Cells(PRow + 5, 1).End(xlDown).Row ' Experience/Location section
            If Cells(PRow + 1, 1).Value <> "" Then
                PRow = Cells(PRow, 1).End(xlDown).Row
            End If
            PRow = Cells(PRow, 1).End(xlDown).Row ' Next Name
        Loop
        .Columns("A:F").AutoFit
    End With

    Application.DisplayAlerts = False
    ActiveSheet.Delete
End Sub

[caunyd]

Hi guys. I am trying to cut and paste a list into Excel, and have Excel separate the different fields for me. There are 11 lines per each entry on the list. I use Firefox as my browser, and when I cut and paste using Firefox into Excel, this is how it looks:


James H. Patel, MD
(space)
Pediatrician
(space)
14642 Newport Ave Ste 450
Tustin, CA 92780
(space)
30 Years Experience
1 Office Location
30 Insurance Carriers
(space)
Mark P. Smith, DO
Etc.
Etc.


I’m hoping for the final product to look like this:
Last Name----First Name----whether MD or DO----Street Address----City, State, Zip code----Zipcode(by itself)

The website that I’m copying and pasting from is:
http://doctor.webmd.com/find-a-docto...fornia/anaheim

I've been trying really hard to understand this stuff, so any help would be greatly appreciated.

[caunyd]

Previously, Natefarm wrote this beauty for me. However, this was when each entry was 12 lines, rather than 11, as it is now. And also the WebMD website might have changed too. Therefore, what Natefarm created doesn't seem to be working anymore. Back then when I cut and pasted from Firefox, it had 1 extra line, and looked like this:

James H. Patel, MD
(space)
Pediatrician
(space)
14642 Newport Ave Ste 450
Tustin, CA 92780
(space)
(extra space)
30 Years Experience
1 Office Location
30 Insurance Carriers
(space)
Mark P. Smith, DO
Etc.
Etc.

This is what Natefarm create:

1. In your workbook, create a sheet called WebMD, and add your column headings.
2. Insert a code module and paste the code below into it.
3. On the Developer tab, click Macros, select PasteWebMD, and click Options.
4. For the Shortcut key, enter p (for Paste), and click Ok and Cancel.
5. Save the workbook as a .xlsm (macro-enabled)

The above is one-time only and sets up the functionality. Then ...

1. On the web page, go to the 1st page.
2. Press Ctrl-A (Select All) and Ctrl-C (Copy).
3. Flip over to the WebMD workbook and press Ctrl-P.
4. Go back to the browser, select the next page, and repeat steps 2 & 3.
5. Continue until you have all the pages.

To avoid needing the mouse, use Alt-Tab to flip back & forth.

You may need to make adjustments if you come across odd names or other issues, but this worked for the 1st 5 pages or so.

Maybe there's a better way to grab a full table out of a web site, but this is the only way I know how to do it.

Option Explicit
Dim PRow As Long, EndRow As Long, MDRow As Long, Txt As String, Pos As Long
Sub PasteWebMD()

    Application.ScreenUpdating = False
    Sheets.Add
    ActiveSheet.Paste
    On Error Resume Next
    Cells.Find(what:="Showing ").Select
    On Error GoTo 0
    If ActiveCell.Address = "$A$1" Then
        MsgBox """Showing"" text not found."
        Exit Sub
    End If
    
    PRow = ActiveCell.Row + 2
    EndRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("WebMD")
        MDRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Do Until PRow > EndRow Or IsNumeric(Cells(PRow, 1).Value)
            Txt = Cells(PRow, 1).Value
            Pos = InStr(Txt, ",")
            If Pos > 0 Then
                .Cells(MDRow, 3).Value = Right(Txt, Len(Txt) - Pos) ' Type
                Txt = Left(Txt, Pos - 1)
            End If
            Pos = InStr(Txt, ".")
            If Pos = 0 Then
                Pos = InStr(Txt, " ")
            End If
            .Cells(MDRow, 1).Value = Right(Txt, Len(Txt) - Pos) ' Last Name
            .Cells(MDRow, 2).Value = Left(Txt, Pos - 1) ' 1st Name
            .Cells(MDRow, 4).Value = Cells(PRow + 4, 1).Value ' Address
            Txt = Cells(PRow + 5, 1).Value
            .Cells(MDRow, 5).Value = Txt ' City, St, Zip
            Pos = InStrRev(Txt, " ")
            .Cells(MDRow, 6).Value = Right(Txt, Len(Txt) - Pos) ' Zip
            
            MDRow = MDRow + 1
            PRow = Cells(PRow + 5, 1).End(xlDown).Row ' Experience/Location section
            If Cells(PRow + 1, 1).Value <> "" Then
                PRow = Cells(PRow, 1).End(xlDown).Row
            End If
            PRow = Cells(PRow, 1).End(xlDown).Row ' Next Name
        Loop
        .Columns("A:F").AutoFit
    End With

    Application.DisplayAlerts = False
    ActiveSheet.Delete
End Sub

I've been trying to modify what he wrote, but it is far beyond my rudimentary skills.

[caunyd]

Natefarm. Thank you, thank you, thank you!!!!! I've been banging my head against the wall trying to do this stuff (unsuccessfully, I might add). The method you have created will make things much less tedious and labor intensive than I could ever imagine. It's everything I could have hoped for! I appreciate your time and effort. Thank you a million more times Natefarm!

[alansidman]

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

[caunyd]

I have another question. Using the method you have devised, can you combine entries that have the same address? For example:

Last Name-----First Name-----Street Address---------City, State and Zip Code
Patel---------James----------9876 Willis Avenue-----Los Angeles, CA 91503
Smith---------Mark-----------9876 Willis Avenue-----Los Angeles, CA 91503
Johnson-------Fred-----------9876 Willis Avenue-----Los Angeles, CA 91503
Reddy---------Gloria---------589848 Kester Blvd-----Portland, OR 543215
Martinez------David----------589848 Kester Blvd-----Portland, OR 543215

I’m hoping for the final product to look like this:

Last Name------------------------Address---------------City, State, and Zip Code
Patel, Smith, Johnson------------9876 Willis Avenue----Los Angeles, CA 91503
Reddy, Martinez------------------589848 Kester Blvd----Portland, OR 543215


Would it be easier to do this by creating a new macro, separate from the one that you have already graciously devised? Because this time, I’m only concerned about combining last names that have the same address, rather than all of those other variables/fields. Thank you once again.

[natefarm]

Well, I'm going to assume that since you already have the WebMD worksheet built, you don't want to have to start all over, going through all the web pages again, so let's treat it as a separate process. The following will make a copy of the WebMD sheet, then convert the data to be as you requested. If it's messed up or we want to make adjustments and do reruns, you'll have your original data intact.

I noticed that the addresses aren't consistent, so you'll still get some duplication, but it will be close.

Copy and paste the following after the existing subroutine and run it separately (just put your cursor somewhere in the subroutine and hit F5).

Sub SortWebMD()
    Sheets("WebMD").Copy after:=Sheets("WebMD")
    ActiveSheet.Name = "WebMD by Address"
    Columns("F:F").Delete ' Zip
    Columns("B:C").Delete ' First Name, Type
    
    EndRow = Cells(Rows.Count, 1).End(xlUp).Row
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("C2:C" & EndRow), Order:=xlAscending
        .SortFields.Add Key:=Range("B2:B" & EndRow), Order:=xlAscending
        .SortFields.Add Key:=Range("A2:A" & EndRow), Order:=xlAscending
        .SetRange Range("A1:F" & EndRow)
        .Header = xlYes
        .Apply
    End With

    MDRow = 2
    Do Until Cells(MDRow, 1).Value = ""
        If Cells(MDRow, 2).Value = Cells(MDRow + 1, 2).Value Then ' same address
            Cells(MDRow, 1).Value = Cells(MDRow, 1).Value & ", " & Cells(MDRow + 1, 1).Value
            Rows(MDRow + 1).Delete
        Else
            MDRow = MDRow + 1
        End If
    Loop
End Sub

[caunyd]

Natefarm. Thank you once again! Not only did you create something better than what I could imagined you made it simple for me to execute by putting basic instructions that even a rookie like me can follow. Thank you so much for your time and assistance!!!

[natefarm]

It does appear that the web page layout has changed. I've adjusted the code. See if this works better.

Option Explicit
Dim PRow As Long, EndRow As Long, MDRow As Long, Txt As String, Pos As Long

Sub PasteWebMD()
    Application.ScreenUpdating = False
    Sheets.Add
    ActiveSheet.Paste
    PRow = 0
    Txt = "Accepting New Patients"
    On Error Resume Next
    PRow = Cells.Find(what:=Txt, LookAt:=xlPart, MatchCase:=False).Row
    On Error GoTo 0
    If PRow = 0 Then
        MsgBox Txt & " text not found."
        Exit Sub
    End If

    EndRow = 0
    Txt = "* First 100 results shown"
    On Error Resume Next
    EndRow = Cells.Find(what:=Txt, LookAt:=xlPart, MatchCase:=False).Row - 1
    On Error GoTo 0
    If EndRow = 0 Then
        MsgBox Txt & " text not found."
        Exit Sub
    End If

    PRow = PRow + 2
    With Sheets("WebMD")
        MDRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        Do Until PRow > EndRow
            Txt = Cells(PRow, 1).Value
            Pos = InStr(Txt, ",")
            If Pos > 0 Then
                .Cells(MDRow, 3).Value = Right(Txt, Len(Txt) - Pos) ' Type
                Txt = Left(Txt, Pos - 1)
            End If
            Pos = InStr(Txt, ".")
            If Pos = 0 Then
                Pos = InStr(Txt, " ")
            End If
            .Cells(MDRow, 1).Value = Trim(Right(Txt, Len(Txt) - Pos)) ' Last Name
            .Cells(MDRow, 2).Value = Left(Txt, Pos - 1) ' 1st Name
            .Cells(MDRow, 4).Value = Cells(PRow + 4, 1).Value ' Address
            Txt = Cells(PRow + 5, 1).Value
            .Cells(MDRow, 5).Value = Txt ' City, St, Zip
            Pos = InStrRev(Txt, " ")
            .Cells(MDRow, 6).Value = Right(Txt, Len(Txt) - Pos) ' Zip

            MDRow = MDRow + 1
            PRow = PRow + 8
            Do Until Cells(PRow, 1).Font.Underline = xlUnderlineStyleSingle Or PRow > EndRow
                PRow = Cells(PRow, 1).End(xlDown).Row ' Find next physician name (underlined)
            Loop
        Loop
        .Columns("A:F").AutoFit
    End With

    Application.DisplayAlerts = False
    ActiveSheet.Delete
End Sub

[caunyd]

Natefarm, thanks once again for putting in the time and effort and coming to the rescue! I was re-reading your original instructions, it's funny, but probably knowing what a rookie I am, you even went so far as to tell me how to use Alt-tab to flip back and forth without the mouse. Your code made this process exceedingly and elegantly efficient and simple for me. Thank you, thank you, thank you again.

[caunyd]

Natefarm, not all the address have a suite number, but when they do, is it possible to separate the street address from the suite number, and put the suite number into another column? Also is it possible to separate the city too? So it looks like:

Last Name----First Name----whether MD or DO----Street Address----Ste Number----City, State, Zip code----City (by itself)----Zipcode(by itself)

Thanks again

[natefarm]

Replace the main Do - Loop portion of the code with the following:

        Do Until PRow > EndRow
            Txt = Cells(PRow, 1).Value
            Pos = InStr(Txt, ",")
            If Pos > 0 Then
                .Cells(MDRow, 3).Value = Right(Txt, Len(Txt) - Pos)    ' Type
                Txt = Left(Txt, Pos - 1)
            End If
            Pos = InStr(Txt, ".")
            If Pos = 0 Then
                Pos = InStr(Txt, " ")
            End If
            .Cells(MDRow, 1).Value = Trim(Right(Txt, Len(Txt) - Pos)) ' Last Name
            .Cells(MDRow, 2).Value = Left(Txt, Pos - 1)               ' 1st Name
            Txt = Cells(PRow + 2, 1).Value
            Pos = InStr(Txt, "Ste")
            If Pos = 0 Then
                .Cells(MDRow, 4).Value = Txt ' Address
            Else
                .Cells(MDRow, 4).Value = Left(Txt, Pos - 2)             ' Address
                .Cells(MDRow, 5).Value = Right(Txt, Len(Txt) - Pos + 1) ' Suite
            End If
            Txt = Cells(PRow + 3, 1).Value
            .Cells(MDRow, 6).Value = Txt                        ' City, St, Zip
            Pos = InStrRev(Txt, " ")
            .Cells(MDRow, 7).Value = Left(Txt, Pos - 5)         ' City
            .Cells(MDRow, 8).Value = Right(Txt, Len(Txt) - Pos) ' Zip

            MDRow = MDRow + 1
            PRow = PRow + 8
            Do Until Cells(PRow, 1).Font.Underline = xlUnderlineStyleSingle Or PRow > EndRow
                PRow = Cells(PRow, 1).End(xlDown).Row ' Find next physician name (underlined)
            Loop
        Loop