• 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.

Copy data from a website to excel

Chris van der Berg

Chris van der Berg

Member
I am totally new to VBA codes, and would like help with the following code:
What I try to achieve:
1. I want to copy the Bible, all Books and verses to excel (One Book at a time)
2. From url www.bybel.co.za
3. Use an input field to select the Bible Book ie. Genesis
4. The VBA code should then select the Book ie. Genesis and copy all verses to excel
5. This is a code I came up with, but needless to say it does not give me the information I want:

Sub GetBibleText()
Dim URL As String
Dim Data As String
Dim mybook As String
Dim Mytext As String
mybook = InputBox("Enter Book")
mytext = InputBox("Enter From text no.")
URL = "www.bybel.co.za/search/search-detail.php?prev=-2&book=(mybook)&chapter=(mytext)&version=1&GO=Wys"
Dim ie As Object
Dim ieDoc As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.navigate URL
Do Until (ie.readyState = 4 And Not ie.Busy)
DoEvents
Loop
Set ieDoc = ie.Document
Data = ieDoc.body.innerText
'Split Data into separate lines
'or just use Range("A1")=data
Dim myarray As Variant
myarray = Split(Data, vbCrLf)
For i = 0 To UBound(myarray)
'Start writing in cell A1
Cells(i + 1, 1) = myarray(i)
Next

ie.Quit
Set ie = Nothing
Set ieDoc = Nothing
End Sub
Can someone please help
Regards

Chris
 
Hi, Chris van der Berg!
I've done such a thing alike, just trying to find it so as to don't write the stuff again. I hope to do it tomorrow, and if I don't succeed I'll try to redo it asap.
In the meanwhile, would you mind emulating Job? :)
Regards!
 
Howzit Chris,

Below is the code generated with Record macro. You will note that the Verse cannot be selected, anyway give this a go. Veels geluk.

Kanti

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.bybel.co.za/search/search-detail.php?prev=-3&book=GEN&version=1&GO=Wys" _
, Destination:=Range("$C$4"))
.Name = "search-detail.php?prev=-3&book=GEN&version=1&GO=Wys"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
 
SirJB7 said:
Hi, Chris van der Berg!
I've done such a thing alike, just trying to find it so as to don't write the stuff again. I hope to do it tomorrow, and if I don't succeed I'll try to redo it asap.
In the meanwhile, would you mind emulating Job? :)
Regards!
Click to expand...

Hi SirJB7,

Thanks for the reply, looking forward to your code.
I have recorded a macro using Data/Importing External Data/New Web Query, but then I have to change the Book name and chapter every time I want to import data from the website.
Kanti did exactly the same in the code he recorded.
If I have to do that, it's easier just to copy/paste directly from the website.
Idealy I would like to use an inputbox to enter the book name with a loop that will run thru all the chapters and copy it to excel.

Regards
Chris
 
kchiba said:
Howzit Chris,

Below is the code generated with Record macro. You will note that the Verse cannot be selected, anyway give this a go. Veels geluk.

Kanti

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://www.bybel.co.za/search/search-detail.php?prev=-3&book=GEN&version=1&GO=Wys" _
, Destination:=Range("$C$4"))
.Name = "search-detail.php?prev=-3&book=GEN&version=1&GO=Wys"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
Click to expand...
 
Hi Kanti,
Like your afrikaans, from where are you ?
Thanks for the code, as you can see from my reply to SirJB7, I tried that.
Lekker dag and thanks for your response.

Chris
 
Hi Chris,

We can build code to wrap around this.

You can have a list of all the books in your workbook with a range of chapters and we can have the macro work through this and get the data. My only problem is I am not sure how to activate the "Wys" or show button with the macro.

cheers

kanti
 
Hi Chris,

I am originally from SA, but have been around since. Currently in Indonesia.

Mooi Bly

Kanti
 
Hi Chris,

I am uploading a very rough macro, with my limited capabilities this is going to take time, so if you bear with me we can do it together.

On a blank worksheet, run the macro and see what comes up, it is taking the names of the Books from the range of names.

I need to understand the rest, so please let me have your feedback.
 

Attachments

  • Get_BIBLE.xlsm
    18.3 KB · Views: 33
Hi Kanti,
I added
GetBook = InputBox("Enter Book Name") below GetBook = Left(ar(x, 1), 3)
When I enter Job the code collect data for Job 17.
Now we need to create a loop that will copy all verses of Job into a workbook.
Maybe we need to change the "Where do you want to put the data" to new worksheet
 
Hi Kanti,

I have added two inputboxes to your code and it seems to work ok, the problem I have is the loop.
When you enter the book name Psa for Psams and enter 1 for chapter the code fetch the info - the loop then starts at "Book" again.
When I enter Psa 2 the code fetch that aswell. After loop 3 it then stop ?? don't know why.

Would like to go to Indonesia one day -That must be the closest I get to Paradise.
 

Attachments

  • Get_BIBLE 1.xlsm
    24.8 KB · Views: 19
Hi Chris,
With the tyranny of time differences I will look at this lot tomorrow

BTW, where are you in SA
 
Howzit Chris,

I was in Pretoria, working in Joburg.
Check out the attached, I have added a button and it will add a new sheet for every Get and will continue to Loop as long as you do not enter Blank for the Book.

Please test and then we can go the next step.

Cheers
Kanti
 

Attachments

  • Get_BIBLE 2.xlsm
    27.3 KB · Views: 16
Hi Chris,
Updated the file to change the sheet names, based on Book and Verse
 

Attachments

  • Get_BIBLE 2.xlsm
    23.9 KB · Views: 28
Hi Kanti,

Great job, thanks a lot for the help, this is going to make my life a lot easier.
Must keep in contact.

Enjoy your day, I am off to work.

Cheers

Chris
 
Hi, Chris van der Berg!

Well, it seem as it's a bit late, but better late than never. Give a look at the uploaded file.

It has 4 worksheets:
Main: book and version selection, and command buttons for getting data.
Tables: books and version tables
Work: used to retrieve web data
Model: used to format books

It'll had an additional worksheet for each book code (3 characters).

Command buttons:
Get book: gets the selected book
Get all books: gets all the books
This is the code in worksheet Main class module to handle them:
Code: 
Option Explicit
 
Private Sub cmdGetBook_Click()
    GetBook Me.cboBooks.Text
End Sub
 
Private Sub cmdGetAllBooks_Click()
    GetAllBooks
End Sub

This is the code in the module MóduloBiblia:
Code: 
Option Explicit

' public constants
Public Const pgksMainWS = "Main"
Public Const pgksTablesWS = "Tables"
Const gksWorkWS = "Work"
Const gkbDebug = True 'True for test, False for usage

Sub GetBook(psBookName As String)
    ' constants
    Const ksBookCode = "ParamBookCode"
    Const ksBookChapters = "ParamBookChapters"
    Const ksVersionCode = "ParamVersionCode"
    ' declarations
    Dim sBookCode As String, iChapters As Integer, iVersion As Integer
    ' start
    ' process
    With Worksheets(pgksMainWS)
        BybleBuild .Range(ksBookCode).Value, _
                    .Range(ksBookChapters).Value, _
                    .Range(ksVersionCode).Value
    End With
    ' end
    Beep
End Sub

Sub GetAllBooks()
    ' constants
    ' declarations
    Dim I As Integer
    ' start
    ' process
    With Worksheets(pgksMainWS)
        For I = 1 To [TableBooks].Rows.Count
            .cboBooks.ListIndex = I - 1
            GetBook .cboBooks.Value
            If gkbDebug And I = 3 Then Exit For
        Next I
    End With
    ' end
    Beep
End Sub

Sub BybleBuild(psBookCode As String, piChapters As Integer, piVersionCode As Integer)
    '
    ' constants
    '  url
    Const ksURL = "http://www.bybel.co.za/search/search-detail.php?book=XXXXX&chapter=YYYYY&version=ZZZZZ&GO=Wys"
    Const ksWildcardBook = "XXXXX"
    Const ksWildcardChapter = "YYYYY"
    Const ksWildcardVersion = "ZZZZZ"
    '  ws & ranges
    Const ksModelWS = "Model"
    Const ksData = "BookChapterDataTable"
    '
    ' declarations
    Dim rng As Range
    Dim sURL As String
    Dim I As Integer, J As Long, K As Long
    '
    ' start
    '  ws
    With ActiveWorkbook
        ' exists?
        For I = 1 To .Worksheets.Count
            With .Worksheets(I)
                If .Name = psBookCode Then Exit For
            End With
        Next I
        If I > .Worksheets.Count Then
            ' create
            .Worksheets.Add , .Worksheets(.Worksheets.Count)
            .Worksheets(I).Name = psBookCode
            ' format 1
            Worksheets(ksModelWS).Rows(1).Copy .Worksheets(I).[A1]
            [C2].Select
            ActiveWindow.FreezePanes = True
        Else
            ' clear
            With .Worksheets(I)
                .Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
            End With
        End If
    End With
    '
    ' process
    With ActiveWorkbook.Worksheets(psBookCode)
        For I = 1 To piChapters
            ' url
            sURL = Replace(Replace(Replace(ksURL, _
                        ksWildcardBook, psBookCode), _
                        ksWildcardChapter, I), _
                        ksWildcardVersion, piVersionCode)
            ' get data
            BybleStealData sURL
            DoEvents
            ' store data
            .Activate
            Set rng = ActiveWorkbook.Worksheets(gksWorkWS).Range(ksData)
            K = .[A1].End(xlDown).End(xlDown).End(xlUp).Row
            For J = 2 To rng.Rows.Count
                If rng.Cells(J, 1).Value = "" Then Exit For
                Range(rng.Cells(J, 1), rng.Cells(J, 3)).Copy .Cells(K + J - 1, 2)
            Next J
            Range(.Cells(K + 1, 1), .Cells(K + J - 2, 1)).Value = I
            Set rng = Nothing
            .Cells(K + J - 2, 1).Select
            If gkbDebug And I = 3 Then Exit For
        Next I
    End With
    '
    ' end
    '  format 2
    With ActiveWorkbook
        With .Worksheets(ksModelWS)
            .Activate
            .Cells.Copy
            .[A1].Select
        End With
        With .Worksheets(psBookCode)
            .Activate
            .Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            .Columns("A:B").HorizontalAlignment = xlCenter
            .[C2].Select
        End With
    End With
    Application.CutCopyMode = False
    '
End Sub

Private Sub BybleStealData(psURL As String)
    ' constants
    ' declarations
    ' start
    Application.ScreenUpdating = False
    With ActiveWorkbook.Worksheets(gksWorkWS)
        .Activate
        .Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
    End With
    ' process
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & psURL, Destination:=[A1])
        .Name = "zBybleSteal"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    ' end
    Application.ScreenUpdating = True
End Sub

If the books or chapters were going to change the following macro in the workbook class module could be updated to retrieve the actual books & chapters lists. Thing that I don't believe it'd happen. If it does, just advise.
Code: 
Option Explicit
 
Private Sub Workbook_Open()
    ' constants
    Const ksAdmiration = "!"
    ' declarations
    Dim A As String
    ' start
    ' process
    ' end
    A = pgksTablesWS & ksAdmiration
    With Worksheets(pgksMainWS)
        .cboBooks.ListFillRange = A & [TableBooks[Book Name]].Address
        .cboVersions.ListFillRange = A & [TableVersions[Description]].Address
    End With
End Sub

Just advise if any issue.

Regards!
 

Attachments

  • Copy data from a website to excel - Web page analysis (for Chris van der Berg at chandoo.org).xlsm
    60.8 KB · Views: 89
Hi, Chris van der Berg!

Glad you solved it. Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.

But..., in this case it's the byble, so I don't think there'll be soon new editions, or revisions, or books added, but generally speaking the ideal would be to retrieve the name of the actual books, the no. of chapters of each one, and the available revisions.

This should be done into the code of the workbook open event and it must update the two tables available. Until someone discovers how to do it and I could borrow the idea with or w/o permission, or until I find out the way (just have to read a little more about Java, DOM & other stuff, otherwise I'm clueless), the tricky but effective way is to parse the HTML content, as in this example:
http://chandoo.org/forum/threads/sp...yond-excel-39-s-capabilities.9640/#post-55329

If you require that, just try to find me in one of my non-lazy days (last one was when Gregorian calendar started... nop, that was when my friend b(ut)ob(ut)hc started school...).

Regards!
 
Hi, Chris van der Berg!

:eek::oops::rolleyes:o_O Who was the guy who didn't changed the value of this constant?
Const gkbDebug = True 'True for test, False for usage
Used at GetAllBooks:
If gkbDebug And I = 3 Then Exit For
and at BybleBuild(...):
If gkbDebug And I = 3 Then Exit For

I know who was the one who didn't explicitly explained that... but I'm not going to reveal his name.

Regards!
 
SirJB7 said:
[…] or until I find out the way (just have to read a little more about Java, DOM & other stuff, otherwise I'm clueless), the tricky but effective way is to parse the HTML content
Click to expand...
Hi SirJB7,​
​
I use such a procedure since years for financial applications among others !​
​
QueryTable is useful for automatically filling table data in columns​
but sometimes I found it slower than parsing text from an html page (inner text) …​
​
An exemple as you mentioned (launch procedure DemoBybel​
to see a complete book loaded in current worksheet) :​
Code: 
Private Declare Function InternetCheckConnectionA Lib "Wininet" (ByVal Site$, ByVal one&, _
                                                                 ByVal zero&) As Boolean

Function WebOK(Optional ByVal URL$ = "http://www.msn.com") As Boolean
            P& = InStr(8, URL, "/"):  If P Then URL = Left$(URL, P)
         WebOK = InternetCheckConnectionA(URL, 1, 0)
End Function


Function WebPage$(PAGE$)
    If WebOK(PAGE) = False Then Exit Function

    With CreateObject("Microsoft.XMLHTTP")
        .Open "POST", PAGE, False
        .Send
        If .Status = 200 Then WebPage = .responseText
    End With
End Function


Function WebText$(SOURCE$, Optional ByVal START$)
     T$ = WebPage(SOURCE)

     If T > "" Then
         If InStr(T, "<body") Then
            With CreateObject("HTMLfile")
                .Write T
                T = .body.innerText
            End With
         End If

         If START > "" Then
             S& = InStr(T, START)
             If S Then T = Mid$(T, S) Else T = ""
         End If

         WebText = T
     End If
End Function


Sub DemoBybel()
    Const ADR$ = "http://www.bybel.co.za/search/search-detail.php?version=1&book="

    Application.ScreenUpdating = False
                 [A1:C1].Value = [{"Vers nr","Vers","Voetnota"}]
                           BK$ = "RUT"
    Do
        C% = C% + 1
        R& = R& + 1
        AR = Split(WebText(ADR & BK & "&chapter=" & C, "Vers nr"), vbNewLine)

        If UBound(AR) > 3 Then
            For N& = 1 To UBound(AR)
                V = Val(AR(N))

                If V Then
                                        R = R + 1
                                       S$ = C & ":" & V
                        Cells(R, 1).Value = BK & "  " & S
                                       B$ = Mid$(AR(N), Len(V) + 1)
                                       P% = InStr(B, S)
                    If P Then
                        Cells(R, 3).Value = Mid$(B, P)
                                        B = Left$(B, P - 1)
                    End If

                        Cells(R, 2).Value = B
                End If
            Next
        End If
    Loop While UBound(AR) > 3

    Application.ScreenUpdating = True
End Sub
Like it !​
​
Carlsberg ! (means in some odd language Regards !)​
 
@Marc L
Hi!
Thanks for the tip, will test it soon. But the best part of all it was your last line. :cool:
ReCarlgardsberg!
 
You must log in or register to reply here.
Back
Top