• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Capturing Web Data as per the Financial Year

N

nkms143

Member
Hi all, I need VBA to Capture Web Data from a Web Link. I have VAB Code Which Works fine. But i need VBA Code which will extract Data as per Financial Year we Want. Workbook is herewith attached for the reference. Web link is Posted in Private Sub Routine of the Macro.
 

Attachments

  • Fetch_from_Web.xlsm
    34.3 KB · Views: 9
Sorry for the inconvenience. Actually, i want to capture Bank Linkage Report table from the following link,
http://efms.serp.telangana.gov.in/MEPMATG/View/Reports/BLTargetAchievementDisbursementReport.aspx.
I do have a VBA code to extract the above Report District Wise and ULB Wise. The Sample file was uploaded in earlier conversion.
But the above Link By Default is loading the report for the Financial year 2015-2016 which has ended. Now I need the Bank Linkage report for the current Financial Year i.e.2016-2017. However, the Code which I got loads the Data from the previous Year(2015-16). So, I need assistance in Modification of code, so that i can capture data from the Current Financial Year (2016-2017). I'm Uploading the file for the assistance.
 

Attachments

  • Fetch_from_Web.xlsm
    34.3 KB · Views: 10
Clear entire code module and paste this code
(no reference anymore like your previous gas factory code needs) :​
Code: 
Sub FetchFromWeb()
    Const STB = "        Web  Import  :  ", _
          URL = "http://efms.serp.telangana.gov.in/MEPMATG/View/Reports/BLTargetAchievementDisbursementReport.aspx", _
          OPT = "ctl00$ContentPlaceHolder1$ddlFinancialYear=2016-2017&__EVENTTARGET=", _
          TBL = "ctl00_ContentPlaceHolder1_gvBankLinkage", _
          CFY = "ctl00_ContentPlaceHolder1_ddlFinancialYear"
    Dim oDoc As Object, oReq As Object, oHlk As Hyperlink, oRng As Range, DCS$, USS As Boolean
    Set oDoc = CreateObject("HTMLfile")
    Set oRng = Cells(1)
    For Each oReq In Worksheets:  oReq.UsedRange.Clear:  Next
With Application
    .ScreenUpdating = False
       DCS = .DecimalSeparator
    If DCS <> "." Then .DecimalSeparator = ".": USS = .UseSystemSeparators: .UseSystemSeparators = False
        .StatusBar = STB & ActiveSheet.Name
    Set oReq = CreateObject("WinHttp.WinHttpRequest.5.1")
        oReq.Open "POST", URL, False
        oReq.setRequestHeader "DNT", "1"
        oReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
     On Error GoTo Fin
        oReq.send OPT & Split(OPT, "=")(0)
     If oReq.Status = 200 Then
           oDoc.body.innerHTML = oReq.responseText
        If oDoc.frames.clipboardData.setData("Text", oDoc.all(TBL).outerHTML) Then
            ActiveSheet.Paste oRng
            oRng.Value = oDoc.all(CFY).Value
            With ActiveSheet.UsedRange.Columns(1):  .WrapText = False:  .AutoFit:  End With
        End If
      End If
    For Each oHlk In ActiveSheet.Hyperlinks
        .StatusBar = STB & oHlk.Range.Value
        oReq.Open "POST", URL, False
        oReq.setRequestHeader "DNT", "1"
        oReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        oReq.send OPT & Split(oHlk.Address, "'")(1)
                              oHlk.Address = ""
    If oReq.Status = 200 Then
        If Evaluate("ISREF('" & oHlk.Range.Value & "'!A1)") = False Then _
            Worksheets.Add(, Worksheets(Worksheets.Count)).Name = oHlk.Range.Value
           oHlk.SubAddress = "'" & oHlk.Range.Value & "'!A1"
           oDoc.body.innerHTML = oReq.responseText
        If oDoc.frames.clipboardData.setData("Text", oDoc.all(TBL).outerHTML) Then
            With Worksheets(oHlk.Range.Value)
                .Paste .Cells(1)
                .Cells(1).Value = oDoc.all(CFY).Value
                With .UsedRange.Columns(1):  .WrapText = False:  .AutoFit:  End With
            End With
        End If
    End If
    Next
Fin:
    If Err.Number Then Beep
    oDoc.frames.clipboardData.clearData "Text"
    If DCS <> "." Then .DecimalSeparator = DCS: .UseSystemSeparators = USS
    .StatusBar = False
    .Goto oRng, True
    .ScreenUpdating = True
End With
    Set oDoc = Nothing:  Set oReq = Nothing:  Set oRng = Nothing
End Sub
Do you like it ? So thanks to click on bottom right Like !
​
 
That Was Truly Awesome. I mean, it is importing the Web Data without consent of browser. Truly amazing.... How is it possible !!!!!!!!!!
 
It is possible as explained in my first post link :
it's just the way used by webbrowsers to query data on servers !

Piloting a webbrowser is often the worst way, at least the slowest :
on my tests computer, my revisited version of your code piloting IE
needs 61,809s to download all tabs,
my requesting code lasts only 6,043s to execute the same
with around half number of codelines …
You can see the requesting speed by looking at bottom status bar.
​
 
Yes I Do... It was an amazing speed. However, it is very difficult for me to understand the code. Last favor, If I want the First page and only one page out of Next 10 Page of my choice, it would be possible?????
suppose, i want data of 1st Page and then Only "Karimnagar" Data. what should I Do....
 
As you can see within your webbrowser if you read my first post link,
my code just reproduces requests used by any webbrowser …

An easy way may be a mod version downloading only existing tabs
or a version using a column with "X" for Muncipal tabs to download
or just by a right click on a district name for example …
​
 
To update existing tabs :​
Code: 
Sub WebUpdateTabs()
    Const STB = "        Web  Import  :  ", _
          URL = "http://efms.serp.telangana.gov.in/MEPMATG/View/Reports/BLTargetAchievementDisbursementReport.aspx", _
          OPT = "ctl00$ContentPlaceHolder1$ddlFinancialYear=2016-2017&__EVENTTARGET=", _
          TBL = "ctl00_ContentPlaceHolder1_gvBankLinkage", _
          CFY = "ctl00_ContentPlaceHolder1_ddlFinancialYear"
    Dim oDoc As Object, oReq As Object, oHlk As Hyperlink, DCS$, USS As Boolean
    Set oDoc = CreateObject("HTMLfile")
    ActiveSheet.Shapes(1).Visible = False
    For Each oReq In Worksheets:  oReq.UsedRange.Clear:  Next
With Application
       .ScreenUpdating = False
       DCS = .DecimalSeparator
    If DCS <> "." Then .DecimalSeparator = ".": USS = .UseSystemSeparators: .UseSystemSeparators = False
        .StatusBar = STB & ActiveSheet.Name
    Set oReq = CreateObject("WinHttp.WinHttpRequest.5.1")
        oReq.Open "POST", URL, False
        oReq.setRequestHeader "DNT", "1"
        oReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
     On Error GoTo Fin
        oReq.send OPT & Split(OPT, "=")(0)
     If oReq.Status = 200 Then
           oDoc.body.innerHTML = oReq.responseText
        If oDoc.frames.clipboardData.setData("Text", oDoc.all(TBL).outerHTML) Then
            ActiveSheet.Paste Cells(1)
            Cells(1).Value = oDoc.all(CFY).Value
            With ActiveSheet.UsedRange.Columns(1):  .WrapText = False:  .AutoFit:  End With
        End If
     End If
    For Each oHlk In ActiveSheet.Hyperlinks
        If Evaluate("ISREF('" & oHlk.Range.Value & "'!A1)") = False Then
            oHlk.Delete
        Else
            .StatusBar = STB & oHlk.Range.Value
            oReq.Open "POST", URL, False
            oReq.setRequestHeader "DNT", "1"
            oReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
            oReq.send OPT & Split(oHlk.Address, "'")(1)
                                  oHlk.Address = ""
         If oReq.Status = 200 Then
               oHlk.SubAddress = "'" & oHlk.Range.Value & "'!A1"
               oDoc.body.innerHTML = oReq.responseText
            If oDoc.frames.clipboardData.setData("Text", oDoc.all(TBL).outerHTML) Then
                With Worksheets(oHlk.Range.Value)
                    .Paste .Cells(1)
                    .Cells(1).Value = oDoc.all(CFY).Value
                    With .UsedRange.Columns(1):  .WrapText = False:  .AutoFit:  End With
                End With
            End If
         End If
        End If
    Next
Fin:
    If Err.Number Then Beep
    oDoc.frames.clipboardData.clearData "Text"
    If DCS <> "." Then .DecimalSeparator = DCS: .UseSystemSeparators = USS
    .StatusBar = False
    ActiveSheet.Shapes(1).Visible = True
    .ScreenUpdating = True
End With
    Set oDoc = Nothing:  Set oReq = Nothing
End Sub
You may Like it !
​
 
You must log in or register to reply here.
Back
Top