Need help Importing Data using web query to specific Columns

[raghav007]

Hello Friends ,

I need your help with two issues that am facing.
Am trying to copy information from a webpage http://delhichamber.co.in/ListingDetails.asp?MemID=1772

It is a directory.Containing links to every member it has. The info on each page is divided in 3 parts. Name , Business Type , Contact Information.

http://i54.tinypic.com/2j9tm8.jpg
You can see the image on above link to understand what am trying to do.

Now my question is , is it possible to have info collected in specified cells the way I am wanting to do.

And my second question is the macro that am using to fetch information is putting information horizontally in excel.

Here is the macro.

Sub LoopThrough()
Dim WSO As Worksheet
Set WSO = ActiveSheet
For Each Cell In WSO.Range("A1:A5")
ThisURL = "URL;" & Cell.Value

With ActiveSheet.QueryTables.Add(Connection:= _
ThisURL, Destination:= _
Range("$A$23"))
.Name = "ListingDetails.asp?MemID=2302"
.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 = "19,""FormPaddingL"",""FormPaddingL"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-2

Next Cell
End Sub

Sub Getlinks()
For Each h1 In ActiveSheet.Hyperlinks
Cells(hl.Parent.Row, 2).Value = hl.Address
Next hl
End Sub

I am complete noob at programming. So would highly appreciate if anyone here could help me with this.Thanks to all in advance.

 

[raghav007]

Guys can anyone pls help me on this

 

[cgcamal]

Hi raghav,

Try the macro below, but before, within an empty sheet do this:
In A1 put "Name", in B1 put "Business Type" and in C1 put "Contact Information" (as in your sample image).

Then insert the macro in a module and test it with differents MemID's one after another for you to see how the table grows.
(Only is needed to introduce the MemID number, for example 1772, 2302, 2303)

* The macro uses colum F and G as help range, and once data is imported in F:G, the macro will pull
data from F:G to A, B & C columns. After the data is sorted properly in A,B,C, all data in columns F:G is deteled

Sub Import_From_Web()
' Import_From_Web Macro
' Done by César C., 19/06/2011


Application.DisplayAlerts = False
MemID = InputBox("Introduce MemID number")

Cr = Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://delhichamber.co.in/ListingDetails.asp?MemID=" & MemID, Destination:= _
         Range("$F$" & Cr + 1))
        .Name = "ListingDetails.asp?MemID=" & ID & "_5"
'.Name = "ListingDetails.asp?MemID=2302"
        .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 = "19,""FormPaddingL"",""FormPaddingL"""
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
   
'Filling with imported values
    Cr = Columns("F").Find(What:="Business Type:", After:=Range("F" & Cr), LookIn:=xlFormulas _
                    , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
   
    LastR = Range("A" & Rows.Count).End(xlUp).Row
   
    If LastR = 1 Then
        LastR = 2
    Else
        LastR = Range("C" & Rows.Count).End(xlUp).Row + 1
    End If
   
    Cells(LastR, "A") = Cells(Cr, "F").Offset(-2, 0).Value
    Cells(LastR, "B") = Cells(Cr, "F").Offset(0, 1).Value
    Range("G" & Cr + 4 & ":G" & Range("G" & Rows.Count).End(xlUp).Row).Copy Destination:=Cells(LastR, "C")
   
    Columns("A:B").AutoFit
    Columns("F:G").ClearContents 'Delete previous web query in range F:G
Application.DisplayAlerts = True
End Sub

Hope this helps, and be an idea to adapt and get your goal.

Regards

 

[raghav007]

Thank you Cesar C. so much your macro worked like charm. Just the way I wanted it to.With everything absolutely perfect.
I just wanted to know that how can I automate it so that I dont have to put it 2617times.As in the member id starts from 2 and goes till 2617.

Thank you so much once again for your help. I really appreciate it.

 

[cgcamal]

Nice to know it works for you as you want.

Regarding your question, only is needed to include the macro within a loop.
Do this:

At the beginning, instead of this:

'Delete previous web query in range F:G

Application.DisplayAlerts = False
MemID = InputBox("Introduce MemID number")

Use this:

'Delete previous web query in range F:G

Application.DisplayAlerts = False

For MemID = 2 To 2619

Now, at the end, instead of this:

Columns("F:G").ClearContents 
Application.DisplayAlerts = True
End Sub

Use this:

    Columns("F:G").ClearContents
Next
Application.DisplayAlerts = True
End Sub

*If you want to repeat the action for 2617 times it will take some time, you can test for smaller intervals
if you want, only modify the lower limit (2) and upper limit (2619) in the loop.

Best regards

 

[raghav007]

Thank you so much Cesar C. once again and many more times. You`ve really helped me save tons of time. This code again worked like charm.
May god bless you alot and alot.

 

[cgcamal]

You're welcome raghav, I appreciate your grattitude.

Nice to know that will help you

God bless you too.