Looping Marco thur url

[sandy armstrong]

Hello, I have create a marco that will go on a site and extract data. thru a web query.
I would like it to keep looping through the column that has all the urls. and stop at the last row containing a url...

SO....
Column K has the URLS starting at K2 these urls come in because a rss feed

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+L
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.practicelink.com/jobs/297594/RSS/Physician/Cardiology/OH/Genesis%20HealthCare%20System" _
, Destination:=Range("$O$2"))
.Name = "Genesis%20HealthCare%20System"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

when the data is brought back into excel it transposes accross colums O-Y

Please help me solve the mind twister !!!!

[Guido Geurs]

This will loop through the col:

         Range("K2").Activate
         Do While ActiveCell.Value <> ""
            ......
            'Do things
            ......
            ActiveCell.Offset(1, 0).Activate
         Loop

[sandy armstrong]

Thanks Guido, It loops pefectly but i would like to be able to do once it loops through the first url it opens web query and imports some data and transposes it across columnns O-Y and keeps doing these step over and over until it reaches the last entry.
i would like to show what i mean but this is a very confidental list of names cleint that i can not put on this site...
But if this is something that can be done Guido, I really do appreciate the help...

[Guido Geurs]

Just write your code in the 3 lines I have added with :

......
'Do things
......

If You need help, can't you attach a workbook with fictive names like Piet, Jan, ... and data ?
Just to see the structure of the sheet, what is on which place and where data need to be added?
Keep in mind that I can't use the web query ? or well ?

[sandy armstrong]

It worked for the first one brought the data in but it will not do it for the ones after that i going to try to attach the file i know last time there was some issues with that. Also im Rssfeeds i have in this file stopped updating as well.
Thanks Guido for you fast respones like always!!!!!

[Guido Geurs]

Sorry but I have troubles loading it in Office 2003.
Is it possible to attach a file with less data like only the sheet with a row or 10 and the VBA macros ?

[sandy armstrong]

Okay i down sized the file thanks again

[Guido Geurs]

This macro will search the data.
I have put the results in col "O" with a space of 10 rows.
Just set the results on the right location in the sheet.

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+L
'
Dim ARRURL() As String
Dim URLNAME As String
Dim QTidx As Integer
'§ go to first cell
    Range("K2").Activate
'§ loop through sheet
    Do While ActiveCell.Value <> ""
        '§ split URL on "/" in array
        ARRURL = Split(ActiveCell.Value, "/")
        With ActiveSheet.QueryTables
            With .Add(Connection:="URL;" & ActiveCell.Value, _
                        Destination:=Range("$O" & ActiveCell.Row * 10))
                '§ search .Name !! URL can or can NOT end on "/"
                If InStrRev(ActiveCell.Value, "/") = Len(ActiveCell.Value) Then
                    .Name = ARRURL(UBound(ARRURL) - 1)
                Else
                    .Name = ARRURL(UBound(ARRURL))
                End If
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlSpecifiedTables
                .WebFormatting = xlWebFormattingNone
                .WebTables = "6"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
            '§ clear QueryTables
            For QTidx = .Count To 1 Step -1
                .Item(QTidx).Delete
            Next
        End With
        With ActiveCell
            .Offset(1, 0).Activate
        End With
    Loop
End Sub

[sandy armstrong]

OmG!!!! this working Perfect!!! thank you i i am now closer then every i would like to know if how do i transpose the data when it extracts it out of the web.

[sandy armstrong]

Thanks Guido you rock!!!

[Guido Geurs]

Place the data in a NamedRange on the sheet.
I have placed it in "=CHS!$O$10:$P$20" for testing but you have to place it somewhere out of the used colls like "=CHS!$AA$1:$AB$10" or so.
Because the items are not always on the same place (more than one "Contact:" , more than one "Phone:"
number,...) we have to analise the data and place it on the right cell.
I have used 4 cols for "Contact:" and 2 for "Phone:"
You can change this number if there are URL with more data: just insert a Case in the right item and increase the numbers in the next items..

        '§ set data in cells and go 1 cell down
        With ActiveCell
            '§ move data
            For URLDATArow = 1 To Range("URLdata").Rows.Count
                URLDATAdata = Range("URLdata").Cells(URLDATArow, 2).Value
                If URLDATAdata <> "" Then
                    If Range("URLdata").Cells(URLDATArow, 1).Value <> "" Then
                        URLDATAitem = Range("URLdata").Cells(URLDATArow, 1).Value
                        URLDATAitemline = 1
                    Else
                        URLDATAitemline = URLDATAitemline + 1
                    End If
                    Select Case URLDATAitem
                    Case "Contact:"
                        Select Case URLDATAitemline
                        Case 1
                            .Offset(0, 4).Value = URLDATAdata
                        Case 2
                            .Offset(0, 5).Value = URLDATAdata
                        Case 3
                            .Offset(0, 6).Value = URLDATAdata
                        Case 4
                            .Offset(0, 7).Value = URLDATAdata
                        End Select
                    Case "Type of Recruiter:"
                        .Offset(0, 8).Value = URLDATAdata
                    Case "Phone:"
                        Select Case URLDATAitemline
                        Case 1
                            .Offset(0, 9).Value = URLDATAdata
                        Case 2
                            .Offset(0, 10).Value = URLDATAdata
                        End Select
                    Case "Fax:"
                        .Offset(0, 11).Value = URLDATAdata
                    Case "Search Firm:"
                        .Offset(0, 12).Value = URLDATAdata
                    End Select
                End If
            Next
            '§ go 1 cell down
            .Offset(1, 0).Activate
        End With
        ActiveSheet.Range("URLdata").Clear

[sandy armstrong]

Thanks again Guido, for this. I love how it is working... I just have one more question, If thats ok? I would like to know if change the rss feed for another company besides CHS how can i change the code to do the same thing no matter what company it is. The first time you did i was able to change the name of the rss feed to any company but the imported data was not transposing like how it is now" Application-defined or object- defined error is the message i get when i try to change the company name.
Again thanks for your help.

[Guido Geurs]

You have to look how the HTML page is structured!
If you are using IE than click on: Menu - View - Source or save page to your disk and look at it with an HTML viewer, MSword...
Tables can have a name like table 1 in RSS:

....
    <table id="LogInDialog" style="dis....
 

And you can address it with:

 .WebTables = "1"

or

 .WebTables = "LogInDialog"

Or no name like in the RSS pages.
Than you have to count the tables
In the RSS pages the data is stored in the 6th table (in or macro= .WebTables = "6"):

....
    <table border="0" cellpadding="0" cellspacing="0" width="100%">
        <tr>
     <th>
         Contact:
     </th>
     <td>
         Joanne Anderson<br />Coordinator<br />
         Community Health Systems<br />
 
         Franklin, TN 37067
     </td>
     <td rowspan="5">
 
     </td>
        </tr>
        <tr>
     <th>....
 

For another company besides CHS you have to find the data table in the HTML and adapt the macro with(if the type of page is in the same place in the URL !!):

 select case ARRURL(5)
 case "RSS"
    'code for RSS HTMLs
 case "???"
    'code for ??? HTMLs
...
 end select

If the type of page is not on the same place, you can use:

 if Instr(ActiveCell.Value,"RSS") then
    'code for RSS HTMLs
 elseif Instr(ActiveCell.Value,"RSS") then
    'code for ??? HTMLs
...
 else
    Msgbox"URL not found..."
 end if
 

or write a second macro.

[sandy armstrong]

Thanks guido, This is soo confusing to me..... Ok in order for me to do this is first thing set up rss feed right? then name the range where i would like other import data to end up. Or how do i go about setting this up each time so i can get these great results. Thanks Guido i wish i had just half of you programming skill because i trully suck!!!!

[sandy armstrong]

Hey Guido!!! thansk for all your help I finally got it to work.your the best!!!!

[sandy armstrong]

Hey Guido for all the other one that i set up are working just perfect but this one is mal funcution do you think it the code or the web that is making it do this? I attached a copy of this file

[Guido Geurs]

On the second line there is an URL (http://www.practicelink.com/jobs/270.../KY/King's Daughters Medical Center/)
with 3 columns !
You are capturing data outside the named range!
The old range with 2 columns is not cleaned properly (still data in the 3th column), so the named range is moved => error.
solution: dimension the named range with 3 columns like:
=$O$10:$Q$25
You can also use 3 columns for the others.

[sandy armstrong]

Hey Guido... I have a question If i need this automactially happen everytime I press refresh or refresh happens everytime i open the excel sheet and update the sheet with the new Rss feed that just entered could the code you wrote just start automaticallty but from the row that does not contain and data instead of from the top... Thanks for you help always.....

[sandy armstrong]

I have change the code just a little to catch another pieace of data of that same site it is working up until it needs to paste into excel. I would appreciate the help...
I have attached a file.

[Guido Geurs]

This table is not table "6" but table "5" in the URL (starts at line 1400) so in reading the URL the code must be:

...
        .WebFormatting = xlWebFormattingNone
        .WebTables = "5"
        .WebPreFormattedTextToColumns = True
...

Also you can't use the same structure to dump the data in the sheet.
The table structure is=
============================================
Hospital Employed Psychiatry Opportunity

Kings Daughters Medical Center

King's Daughters Medical Center
Ashland , KY 41101
600,000 service area , 2201 Lexington Avenue

Job ID: 266822
Accepts J1s: No
Loan Assistance: Yes
Practice Type: Hospital Employee
Apply Now EmailFacebookTwitterShareThisShareThis
============================================

Also: the contents of the first column is not " trFacility:", " Job ID:", ... with space at beginning !!! but "Job ID: "

If you want the data of column1 for the first 8 rows, you just have to read them and dump in the sheet.

PS: for safer reasons I have placed the "URLdata" range to "AA1:AB20"

[sandy armstrong]

Thats why your an expert and im not!!!! thanks for this im really thankful. I followed the steps of what you have told me in the past posts but My biggest problem was getting the data to display after it came over and wanted it to display the name of the hospital and the address also, Thanks again guido for the help. I am so close thanks to you...

[Guido Geurs]

Is this the data in the 1st column on the 5th row?
If so, see attached demo: just set the data from the named range in the offset cell with:

            .Offset(0, 6).Value = Range("URLdata").Cells(5, 1).Value

PS: I have also done some modifications on the definition and clearing of the named range.

[sandy armstrong]

Hey Guido thanks for getting back to me... I dont know what it is it not getting the hospital name for me
----------------------------------------
----------------------------------------
Hospital Employed Psychiatry Opportunity

Kings Daughters Medical Center

King's Daughters Medical Center
Ashland , KY 41101
600,000 service area , 2201 Lexington Avenue

Job ID: 266822
Accepts J1s: No
Loan Assistance: Yes
Practice Type: Hospital Employee
Apply Now EmailFacebookTwitterShareThisShareThis
-------------------------------------------------
-------------------------------------------------

I would like the 4th and the 5th line of data I tried eveything you told me to do before I looked at the source of the web page and nothing seems to be working for me...

[Guido Geurs]

!! the 4th line is blanc !!!
Must it not be the 3th ??? (see attachment)
----------------------------------------
----------------------------------------
[1]Hospital Employed Psychiatry Opportunity
[2]
[3]Kings Daughters Medical Center
[4]
[5]King's Daughters Medical Center
[6]Ashland , KY 41101
[7]600,000 service area , 2201 Lexington Avenue
....
-------------------------------------------------
-------------------------------------------------

[sandy armstrong]

Thanks Guido Im learning so much from you... I Realize that I said Line 4 from the Example but what i meant was really line 5 and 6 from the data shown above thanks for making it clear to me. I was able fix it with some teaking and tuning and i was proud of myself that i with your help (As Always) i was able to tune it. Now i would like to move it over from the columns that it is being ported into now into another column after column Z. Thanks so much for always getting Back... Guido (!!!!Apperiacted!!!!!)

[Guido Geurs]

To copy a column fast, use arrays like:( to copy col M to Z)
(M1 is title)

Sub macro_copy_Col()
Dim ARRAYDATA As Variant
    ARRAYDATA = Range("M2").Resize(Range("M2").End(xlDown).Row, 1)
    Range("Z2").Resize(UBound(ARRAYDATA, 1), 1) = ARRAYDATA
End Sub

[sandy armstrong]

Thanks Guido, I finally completed this task all thanks to you!!!!

[Guido Geurs]

This is working for CHS contracts (no row jump)

Sub Capturedata()
'§ Keyboard Shortcut: Ctrl+Shift+L
Dim ARRURL() As String '§ for splitting the URL
Dim QT As QueryTable '§ QueryTables in sheet
Dim URLDATArow As Integer
Dim URLDATAitem As String
Dim URLDATAdata As String
Dim URLDATAitemline As Integer
'§ go to first cell
    Range("K2").Activate
'§ loop through sheet
    Do While ActiveCell.Value <> ""
        '§ split URL on "/" in array
        ARRURL = Split(ActiveCell.Value, "/")
        With ActiveSheet.QueryTables
            With .Add(Connection:="URL;" & ActiveCell.Value, _
                        Destination:=Range("URLdata"))
                '§ search .Name !! URL can or can NOT end on "/"
                If InStrRev(ActiveCell.Value, "/") = Len(ActiveCell.Value) Then
                    .Name = ARRURL(UBound(ARRURL) - 1)
                Else
                    .Name = ARRURL(UBound(ARRURL))
                End If
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
                .RefreshPeriod = 0
                .WebSelectionType = xlSpecifiedTables
                .WebFormatting = xlWebFormattingNone
                .WebTables = "6"
                .WebPreFormattedTextToColumns = True
                .WebConsecutiveDelimitersAsOne = True
                .WebSingleBlockTextImport = False
                .WebDisableDateRecognition = False
                .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With
        End With
        '§ clear QueryTables
        For Each QT In ActiveSheet.QueryTables
            QT.Delete
        Next
        '§ set data in cells and go 1 cell down
        With ActiveCell
            '§ move data
            For URLDATArow = 1 To Range("URLdata").Rows.Count
                URLDATAdata = Range("URLdata").Cells(URLDATArow, 2).Value
                If URLDATAdata <> "" Then
                    If Range("URLdata").Cells(URLDATArow, 1).Value <> "" Then
                        URLDATAitem = Range("URLdata").Cells(URLDATArow, 1).Value
                        URLDATAitemline = 1
                    Else
                        URLDATAitemline = URLDATAitemline + 1
                    End If
                    Select Case URLDATAitem
                    Case "Contact:"
                        Select Case URLDATAitemline
                        Case 1
                            .Offset(0, 15).Value = URLDATAdata
                        Case 2
                            .Offset(0, 16).Value = URLDATAdata
                        Case 3
                            .Offset(0, 17).Value = URLDATAdata
                        Case 4
                            .Offset(0, 18).Value = URLDATAdata
                        End Select
                    'Case "Type of Recruiter:"
                   ' Select Case URLDATAitemline
                       ' Case 1
                      '  .Offset(0, 18).Value = URLDATAdata
                     '  End Select
                    Case "Phone:"
                        Select Case URLDATAitemline
                        Case 1
                            .Offset(0, 19).Value = URLDATAdata
                        Case 2
                            .Offset(0, 20).Value = URLDATAdata
                        End Select
                    Case "Fax:"
                      .Offset(0, 21).Value = URLDATAdata
 
                    End Select
                End If
            Next
            '§ go 1 cell down
            .Offset(1, 0).Activate
        End With
        ActiveSheet.Range("URLdata").Clear
    Loop
'    Call Macro1
 End Sub

[sandy armstrong]

Thanks Guido I am Able to do this for every Rss feed I bring in from this site with a little modification I am Very happy with this Thanks so much for helping me with this Again again again Thanks Soooo much!!! Your the Best!!

[sandy armstrong]

Hey Guido Just a thought... Can these to code be combined in order to perform this action together. right now what i do is run one macro then call up the other when that one finishes... I was just thinking it would make it easier. Right now as we speak i am running the first marco on 11,000 and if works great the after that it runs the second part. it takes a whole 24 hours to complete the task fully. Thanks

[sandy armstrong]

Hey Guido,
It been A long time..
I dont know what happened with this code that you helped me delvop. I think the website changed there source code because the marco works but no data is beening imported. I tryed in all the examples that we have copied to this forum and it not working Please Guido call you help me tell what is wrong...
Thanks for you help

[Guido Geurs]

Hello Sandy,
It has been a long time since I have worked on this problem and I don't have the latest code any more (there where also 3 call's on this project).
Please can you attach the workbook with some URL's and the latest macro in?

[sandy armstrong]

OK no problem I have attached the folder Thanks for your help.

[Guido Geurs]

This is a new lay-out for "http://www.careermd.com/physicians/ViewListing.aspx?ListingID=289021711"!
Which data do you want from this URL?

This is the only data I get from the 2 tables in it:

table 1 ===========================================
Tampa Hospitalist Opportunity —
Clearwater, Florida
IN Compass Health, Inc. | Morton Plant Hospital
Job ID: 289021711 | J1s Y/N?: Unspecified
================================================== =


table 2 ===========================================
Contact Person: Matt Griffith , Inside Physician Researcher
Phone: [phone] ext. , Fax:
================================================== =

[sandy armstrong]

Thanks Guido. I attached the wrong work bok my mistake. I have attached the correct one now what is going on is that the marco that goes into the URL in column K and export the data is working but there is no data being place where it needs to go. that is what leads me to be leave that the website change the source code. PLease let me know what you think. Any help is apperciate.

[Guido Geurs]

Attached is a tool to view the tables in an URL.

HOW:
- Show the Form with the macro : Show_URL_Table_Viewer

- Paste the URL addresses in column "A"
- Go with the command buttons (UP, LEFT, RIGHT, DOWN) to the Cell with the URL address (not to fast ! = let the sheet the time to update!)
- Click on "GET URL ADDRESS" to put the URL in the textbox
- Select the table number you want to see with the Up and Down spinbuttons.
- Click on "Show URL Table" to load the table in the range = "B1" to "xxxx"

- Click on the Help button to see this help text.

[Guido Geurs]

The data are now in table=7 (check with tool).
Attached is the new code.

[sandy armstrong]

Guido that table finder is soo cool i love how it works. for table3 it would soo neat if it would bring you the email address also. but i know the email is hidden by a types of fire walls. I love this new tools thanks for your help after all this time.