Copy table from website into excel with VBA

[mcclellan]

Hello there,

I love this website.

I am trying to create a macro that will copy a table from a website and paste it into excel.

How do I do this and how do I identify the table name?

Any help is appreciated.

Michael

 

[jbeaucaire]

Have you looked yet at Excel's built-in ability to do this?

Date > Import External Data > New Web Query

This brings up a mini-web-browser, you can navigate to this table on the internet you want, then click the little arrow next to the table data to turn it green, then IMPORT.

You can set the Properties of this web query to update regularly, perhaps every hour, and your data stays refreshed. Import it to a garbage sheet, then manipulate the data to look the way you want on your display sheets.

Worth looking at.

 

[mcclellan]

Good suggestion. I did try that, but I got an error message every time.

I believe this has something to do with the fact that I must first login to this website.

Michael

 

[jbeaucaire]

Even after you logged into the website? It didn't work after that?

 

[mcclellan]

Yes. The error message is:

"Run time error 1004:

Unable to open https://trading.scottrade.com/default.aspx.
Cannot download the information you requested.

 

[DocAElstein]

Copy Table from Web-Site (Web Scraping?!?)

Hi jbeaucaire,
. I have basic Excel knowledge.
. I have been learning VBA since joining MrExcel a few months ago.
. I wish to import a “Table” from a web site Page into a spreadsheet using VBA based on selection from a large list I have of website Urls / Hyperlinks
. I tried your method, hoping to be able to do it using a macro recording to get started in writing my own code. But I do not get the option of an arrow to click on at the table in which I am interested in, (***probably because I have to make a further click on a small box to open the table or tables of interest to me.)


The hyperlink of interest would be, for example:
Apfel | Kalorien | Nährwerte | Analyse | Lebensmittel - ernaehrung.de
(which gives a site showing Nutrition values for an Apple!). ***Once at the site I must further “Click” on a box to open up, for example “Vitamine” to show the actual table of data interest which I want to get.


Can you (or anyone else out there) help?
. Many Thanks
. Alan Elston


I use XL 2007 and 2010 in Vista and XL 2003 and 2010 in XP
P.s. Actually I am an old practical Physicist

…………………………………….





. P.S. I have already got as far as writing a code which successfully opens the webpage based on my worksheet selection of a URL from a Url or hyperlink list which I have made. And further I have a second code which manipulates the table as I need to once it is copied to a spreadsheet. So I am just missing the “middle” bit which would copy that table from the web site to the Clipboard (or to any excel spreadsheet). I believe this requires the method of “scraping” the website’s HTML Code??

. . having done a lot of Googling etc., I get the idea that I must study the HTML code of the webpage, (which I obtain through an option given to me when I click the right mouse button when in the web Page), then pick out the bits that I need such as the click bit code reference as well as the actual data I want, using appropriate VBA code to do that. That is to say I must get names and items I need to reference with library elements / functions etc. from the IE object which I have successfully created and used to get the webpage open. But for someone with no experience in that area it is a bit of a big job, and maybe someone could give me a bit of a starter, for example give a code to get that vitamine table. I can then study that, learn from it and comparing it with the website HTML code which I have been studying I could work out the rest myself to get the complete data.
. Currently I simply use my first code to get the website, then while I have it waiting a bit, I copy by hand with Ctrl C the tables to the clipboard then paste in a spreadsheet with Ctrl V like this :

Book1
	A	B	C
1	Inhaltsstoff	Menge	Einheit
2	Vitamin A Retinol	0,00	mg
3	Vitamin D	0,00	g
4	Vitamin E Aktiv.	0,69	mg
5	Folsure	30,00	g
6	Vitamin B1	0,02	mg
7	Vitamin B2	0,05	mg
8	Vitamin B6	0,08	mg
9	Vitamin C	25,00	mg
10	a-Tocopherol	0,69	mg
11	Vitamin K	10,00	g
12	Nicotinamid		g
13	Pantothensure	0,30	mg
14	Biotin	2,00	g
15	Vitamin B12	0,00	g
16	Retinolquivalent	3,00	g
17	-Carotin	16,00	g
18	Niacinquivalent	567,00	g
19	freies Folsurequivalent		g
20	freie Folsure		g
Sheet1

. Here is my first code I knocked up (which seems to work best in my system+++) to get the website up and running based on appropriate selection of Urls. (basically I want to replace the bit where it tells me through the StatusBar to open the table or tables and copy and paste the table or tables by hand, with a code to do just that.):
First (Main) Code

[color=darkblue]Option[/color] [color=darkblue]Explicit[/color] [color=green]'Force me and help to get variables fully defined.[/color]
[color=darkblue]Sub[/color] MrExcelGetDebinetInfoExample()
[color=green]'Before running this select the Url string of the food Product of interest from[/color]
  [color=darkblue]Dim[/color] LinkHitFlag [color=darkblue]As[/color] [color=darkblue]Boolean[/color] [color=green]'To Indicate when a Url Link is obtained and we then set a Internet Explorer Instance[/color]
  [color=darkblue]On[/color] [color=darkblue]Error[/color] [color=darkblue]Resume[/color] [color=darkblue]Next[/color] [color=green]'If Internet crashes or does not work or freezes etc. just carry on., - my looping work around (Bodge) usually sorts those error out!![/color]
 
[color=green]'*****Set Typical variables and give some abbreviaiotns for objects with all the methods and properties of The object through the .dot thing[/color]
  [color=darkblue]Dim[/color] wksLookUpTable [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wksLookUpTable = ThisWorkbook.Worksheets("FoodsLookUpTable")
  [color=darkblue]Dim[/color] wksCopiedTables [color=darkblue]As[/color] Worksheet: [color=darkblue]Set[/color] wksCopiedTables = ThisWorkbook.Worksheets("Sheet1")
  [color=darkblue]Dim[/color] StrHomeUrl [color=darkblue]As[/color] [color=darkblue]String[/color], StrFoodsUrl  [color=darkblue]As[/color] [color=darkblue]String[/color], StrFoodUrl [color=darkblue]As[/color] [color=darkblue]String[/color] [color=green]' Url paths as strings[/color]
 
  [color=darkblue]Dim[/color] appIE [color=darkblue]As[/color] [color=darkblue]Object[/color] [color=green]'InternetExplorer as an Object for OOP - IE. This Application is there and can be refered to as an object just like Excel itself, and it has Methods and properties you can use then for doing Browser stuff. (I could not find a Google Chrome equivalent!?!... once again  - "Good old Browser!!")[/color]
 
[color=green]'****looping here is just part of Bodge to keep Browser active and "happy" for a while[/color]
  [color=darkblue]Dim[/color] Wait [color=darkblue]As[/color] [color=darkblue]Long[/color], Hit [color=darkblue]As[/color] [color=darkblue]Long[/color], LoopBoundVariableCount [color=darkblue]As[/color] Long: [color=darkblue]Let[/color] Hit = 0 [color=green]'**** Some variable used in the Bodge to get Internet Explorer Browser to behave Itself!![/color]
    [color=darkblue]For[/color] LoopBoundVariableCount = 1 [color=darkblue]To[/color] 3 [color=darkblue]Step[/color] 1
    [color=darkblue]Let[/color] LinkHitFlag = [color=darkblue]False[/color] [color=green]'Start looking for Url so have no InternetExplorer Set[/color]
 
    Set appIE = CreateObject("InternetExplorer.Application")
        [color=green]'The above two appIE commands (Dim appIE and Set appIE are example of "Late Binding" method, usually preferred especially when passing the code to others. it can lead to some limitations in available commands. A Second alternative, referred to as "Early binding" Requires making the approprite library available with     Tools>>References>>scrolldown and check the box next to Microsoft Internet Controls then:[/color]
[color=green]'            Dim appIE As InternetExplorer[/color]
[color=green]'            [color=darkblue]Set[/color] appIE = New InternetExplorer[/color]
        [color=green]'This method has the adventage in developing as then the VBA intellisense (.dot Stuff) will show the members of the IE object.[/color]
   
    appIE.Silent = [color=darkblue]True[/color] [color=green]' Disable pop-up msgs[/color]
    appIE.Visible = [color=darkblue]True[/color] [color=green]'See Browser!! - False would "Hide" it![/color]
    [color=darkblue]Let[/color] StrHomeUrl = "http://www.ernaehrung.de/"
    appIE.Navigate StrHomeUrl
    Application.StatusBar = "Navigating to: " & StrHomeUrl & " ..." [color=green]'Navigating initially to Home Page....[/color]
   
                        [color=green]'  Application.StatusBar = "Waiting for IE's complete state..."[/color]
                        [color=green]'   Do Until appIE.Readystate = 4:DoEvents: Loop[/color]
                               
                        [color=green]'  Application.StatusBar = "Waiting for Document's downloaded state..."[/color]
                        [color=green]'   While appIE.Document Is Nothing:DoEvents: Wend[/color]
    Application.Wait Now + TimeValue("00:00:03") [color=green]'Wait a bit after valid page is opened - found in practice to work better than the two conventional methods Commented our above[/color]
    
     [color=darkblue]Let[/color] StrFoodsUrl = "http://www.ernaehrung.de/lebensmittel/": appIE.Navigate StrFoodsUrl
     Application.StatusBar = "Navigating to: " & StrFoodsUrl & " ..." [color=green]'... then Navigating to foods....[/color]
     Application.Wait Now + TimeValue("00:00:03") [color=green]'Wait a bit again after valid page is opened - found in practice to work better than the two conventional methods Commented our above[/color]
    
     wksLookUpTable.Activate [color=green]'Make sure the sheet with selected Url is active or wrong "Actice cell" will be selected! (See here:   http://www.mrexcel.com/forum/general-excel-discussion-other-questions/780223-many-active-cells-you-like-once%85-o00o-%60-_-%60-o00o-oop-hierarchy.html?   )[/color]
     [color=darkblue]Dim[/color] FileName [color=darkblue]As[/color] String: [color=darkblue]Let[/color] FileName = ThisWorkbook.Name [color=green]'Need to do a bit of mucking about to get the window name[/color]
     [color=darkblue]Dim[/color] WindowName [color=darkblue]As[/color] [color=darkblue]String[/color] [color=green]'File name as typically seen displayed without last bit after dot[/color]
     [color=darkblue]Let[/color] WindowName = Left(FileName, (InStrRev(FileName, ".") - 1)) [color=green]'Take off the bit after the dot[/color]
     [color=darkblue]Let[/color] StrFoodUrl = Windows(WindowName).ActiveCell.Value: appIE.Navigate StrFoodUrl
     Application.StatusBar = "Navigating to: " & StrFoodUrl & " ..." [color=green]'Navigating to page we want. (Found in practice works better (errors less) if navigate to hime page then FoodS page first)[/color]
     Application.Wait Now + TimeValue("00:00:03") [color=green]'Wait a bit again after valid page is opened - found in practice to work better than the two conventional methods Commented our above[/color]
    
     [color=darkblue]Let[/color] Hit = Hit + 1: [color=darkblue]Let[/color] LinkHitFlag = [color=darkblue]True[/color] [color=green]' If we are here we scored!, that is to say did not crash!! (I think acccording to how "On Error Resume Next works)[/color]
    
[color=green]'#####################################################################################################[/color]
[color=green]'##  I NEED CODE LINES HERE PLEASE TO COPY THE TABLE VIA VBA TO SHEET1[/color]
[color=green]'##  For exampole: Pick out the Vitamie Table got by clicking on a box[/color]
[color=green]'##    in this Link:      http://www.ernaehrung.de/lebensmittel/de/F110000/Apfel.php[/color]
 
     Application.StatusBar = "Loop Number " & LoopBoundVariableCount & "   Hit " & Hit & "   Wate-In a bit so you can copy the table or tables into Sheet1 of this Workbook"
     Application.Wait (Now + TimeValue("0:00:0" & [color=darkblue]CStr[/color](Int(10 * Rnd) + 13))) [color=green]'This bodge gives me a wait period of 20 - 30 seconds which seems to help stop my [color=darkblue]In[/color]ternet provider switching me off periodically to stop me "Abusing" my Flat-Rate and staying "On" for a long while!!![/color]
[color=green]'##[/color]
'##
'##
'######################################################################################################
     
      [color=darkblue]If[/color] LinkHitFlag = [color=darkblue]True[/color] [color=darkblue]Then[/color] [color=green]' This is all still part of "behave youself Bodge!"[/color]
      appIE.Quit
      [color=darkblue]Set[/color] appIE = [color=darkblue]Nothing[/color]
      [color=darkblue]Else[/color] [color=green]'Do not try to quit was is not there!![/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
  
     Application.StatusBar = [color=darkblue]False[/color]
     wksCopiedTables.Activate [color=green]'Re-Activate the sheet with table in so we can check it[/color]
     [color=darkblue]Next[/color] LoopBoundVariableCount
 
    [color=green]'----Tidy up with NateO's IE_Sledgehammer() just in case looping freaks out Opened lots of Browsers[/color]
    [color=darkblue]Dim[/color] objWMI [color=darkblue]As[/color] [color=darkblue]Object[/color], objProcess [color=darkblue]As[/color] [color=darkblue]Object[/color], objProcesses [color=darkblue]As[/color] [color=darkblue]Object[/color]
    [color=darkblue]Set[/color] objWMI = GetObject("winmgmts://.")
    [color=darkblue]Set[/color] objProcesses = objWMI.ExecQuery( _
        "SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
      [color=darkblue]For[/color] [color=darkblue]Each[/color] objProcess In objProcesses
      [color=darkblue]Call[/color] objProcess.Terminate
      [color=darkblue]Next[/color]
    [color=darkblue]Set[/color] objProcesses = Nothing: Set objWMI = Nothing
    [color=green]'--------[/color]
   
  Application.StatusBar = [color=darkblue]False[/color]
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'MrExcelGetDebinetInfoExample()[/color]

(+++. Note the code does a strange looping a few times. I cannot explain why this was necessary. I simply found by a lot of trial and error it was necessary to do this. Simply opening once and Or refreshing or changing the page with code always caused strange problems on all my computers after 7 – 10 minutes. I expect there may be something organized by my internet provider to attempt to prevent me from using my “Flat-Rate” to its full!. By trial and error I found a way to out trick it (I think?) using this unconventional looping method which opens and closes in a loop with random waiting intervals)

The codes relevant to this thread are in a module called “ForMrExcelFredWebScraping” in this File as well as a small part of the Url Look up table. (Xl 2007 .xlsm):
https://app.box.com/s/6j9vt55zbbnd0u805tx6
The first code “'MrExcelGetDebinetInfoExample() “ Is the main one of relevance to my problem.
First Code:
………………..

. My second code “ MrExcelDebiNetPutInPetrasDecDump() “ and relevant file for final output I also include for interest and completeness, although they are not directly related to my problem. This second code manipulates the data to put it in the appropriate place in this (XL2007.xlsx) File:
https://app.box.com/s/t0utcujdggd7sm8xr1x4 (Based on appropriate selection of Active cell in column A for output row for data input .)
. I have no problem in changing this to suit if the table obtained by a code comes out in a different format. This second code is not as complicated as it looks – As it is both for a RL application and because I am keen to learn I am trying lots of different methods, many of which are then commented out. (Here is the File with macros in it (XL2007.xlsm) as well as a small part of the Url Look up table.



Second Code: (Not too relevant to my problem)

[color=darkblue]Sub[/color] MrExcelDebiNetPutInPetrasDecDump()
[color=green]'   Before running this code the table from the Webpage should be pasted in left hand upper corner of sheet1 of this workbook[/color]
[color=darkblue]Dim[/color] wkshtDebTab [color=darkblue]As[/color] Worksheet [color=green]' Give Properties and methods through dot thing to the abbreviations[/color]
[color=darkblue]Set[/color] wkshtDebTab = ThisWorkbook.Worksheets("Sheet1") [color=green]'    .. or 'Set wkshtDebTab = Workbooks("ForMrExcelDebiNetGetExample.xlsm").Worksheets("Sheet1")[/color]
 
[color=green]' I am deliberately Dimensioning and setting more than things than I need to give more flexibility in adapting the code later[/color]
[color=darkblue]Dim[/color] ScreenCapture() [color=darkblue]As[/color] Range, ScreenValues() [color=darkblue]As[/color] [color=darkblue]String[/color], ScreenThings() [color=darkblue]As[/color] [color=darkblue]Variant[/color] [color=green]'****-over-Tit Excel arrays for Debinet Vitamine Tables[/color]
[color=green]'  "ScreenCapture" - Alan idea for getting close to wot is really there - Range has lots of info in[/color]
[color=darkblue]Let[/color] ScreenThings = wkshtDebTab.Range("A1").CurrentRegion [color=green]'I Think this is more subtle than it looks: Putting an Array without the () = to a range is a strange idea, but apparantly that is an Instruction to Array with variant Elements. Then The Default type of array (variables) seems to be one that has variable type that Excel can co-coerce to what it decides they are, so that's why I dimensioned it as variant[/color]
[color=darkblue]Let[/color] ScreenThings() = wkshtDebTab.Range("A1").CurrentRegion.Value [color=green]'This is Better, more precise and as roryA said her (  http://www.mrexcel.com/forum/excel-questions/817965-dimension-array-range-anomaly.html?  and here   http://www.mrexcel.com/forum/excel-questions/817446-range%3D-equivalent-range-value%3D-sometimes-range-range-value-anomaly.html    )     : " when you mean .Value, write .Value. Never use implicit defaults because it will bite you when you don't expect it if you do"[/color]
[color=darkblue]Dim[/color] ScnFgsStRow [color=darkblue]As[/color] [color=darkblue]Long[/color], ScnFgsRows [color=darkblue]As[/color] [color=darkblue]Long[/color], ScnFgsStClm [color=darkblue]As[/color] [color=darkblue]Long[/color], ScnFgsClms [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Let[/color] ScnFgsStRow = wkshtDebTab.Range("A1").CurrentRegion.Row: [color=darkblue]Let[/color] ScnFgsRows = wkshtDebTab.Range("A1").CurrentRegion.Rows.Count: [color=darkblue]Let[/color] ScnFgsStClm = wkshtDebTab.Range("A1").CurrentRegion.Column: [color=darkblue]Let[/color] ScnFgsClms = wkshtDebTab.Range("A1").CurrentRegion.Columns.Count
[color=green]'Or this would work if excel had chosen to take all the elements as strings. Bit tricky, especially when dealing with diffferent . and , conventiions in German and English[/color]
[color=green]'         Let ScreenValues = wkshtDebTab.Range("A1").CurrentRegion '- Type uncompatible  'Let ScreenValues = wkshtDebTab.Range("A1").CurrentRegion.Values '-Object doesn't supports this property or method[/color]
 [color=green]'       'Set ScreenValues = wkshtDebTab.Range("A1").CurrentRegion 'Keine zuweisung an datafield mogleich: No refer to data Field possible[/color]
[color=green]'Or rather than an array, use a range[/color]
[color=darkblue]Dim[/color] ScreenThingsAsRange As Range
[color=darkblue]Set[/color] ScreenThingsAsRange = wkshtDebTab.Range("A1").CurrentRegion [color=green]'Same Instruction to Range Object this time, but looks more "Beleivable" than the Array assigning stuff above[/color]
[color=darkblue]Let[/color] ScnFgsStRow = ScreenThingsAsRange.Row: [color=darkblue]Let[/color] ScnFgsRows = ScreenThingsAsRange.Count: [color=darkblue]Let[/color] ScnFgsStClm = ScreenThingsAsRange.Column: [color=darkblue]Let[/color] ScnFgsClms = ScreenThings[color=darkblue]As[/color]Range.Columns.Count
 
 
[color=darkblue]Dim[/color] TableRow [color=darkblue]As[/color] [color=darkblue]Long[/color], TableClm [color=darkblue]As[/color] [color=darkblue]Long[/color], LastRowTable [color=darkblue]As[/color] [color=darkblue]Long[/color], LastClmTable As [color=darkblue]Long[/color] [color=green]'Self explanitary variables for the table. Long is a very big number, but as smaller ones are coerced into this usually by VBA there is no memory advantage of using dimensioning to smaller[/color]
[color=darkblue]Let[/color] LastRowTable = [color=darkblue]UBound[/color](ScreenThings, 1): LastClmTable = [color=darkblue]UBound[/color](ScreenThings, 2) [color=green]'Just a convenient way of getting maximumtable co-ordinate. Note again the ****-over-tit excel convention, co-ordinate ,1 is y-axis and ,2 co-ordinate is x-axis. NOTE: Assumes starting at A1, so that first row and column are 1 and 1. And note for the .used range to work there should be at least one Row/ column space, that is to say empty cells around the perimeter of the table[/color]
 
 
 
[color=darkblue]ReDim[/color] ScreenCapture(1 [color=darkblue]To[/color] LastRowTable, 1 [color=darkblue]To[/color] LastClmTable) [color=green]'We have the info now to dimension our Array of ranges[/color]
  [color=green]'The following is the only way I know for now to populate the "capture" Array with ranges[/color]
  [color=darkblue]For[/color] TableClm = 1 [color=darkblue]To[/color] LastClmTable [color=darkblue]Step[/color] 1 [color=green]'going along columns and then...[/color]
    [color=darkblue]For[/color] TableRow = 1 [color=darkblue]To[/color] LastRowTable [color=green]'...go down each row[/color]
      [color=darkblue]Set[/color] ScreenCapture(TableRow, TableClm) = wkshtDebTab.Cells(TableRow, TableClm) [color=green]'Puts a Range NOT a value in each Array Element[/color]
    [color=darkblue]Next[/color] TableRow
  [color=darkblue]Next[/color] TableClm
 
[color=green]'Trying some Re-Pasting of Table[/color]
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenThings [color=green]'  ....[/color]
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenThings ' Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(12, 3).Value = ScreenThings.Value-'.... ScreenThings is invalid identifier !?
 
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenCapture
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenCapture [color=green]'   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(12, 3).Value = ScreenCapture.Value '.... ScreenCapture is invalid identifier !?[/color]
 
[color=green]'   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenThingsAsRange'   Gives Empty cells-  -Suffice to say, when you mean .Value, write .Value. Never use implicit defaults because it will bite you when you don't expect it if you do - Resting our cases: - Not working for us      ....http://www.mrexcel.com/forum/excel-questions/817446-range%3D-equivalent-range-value%3D-sometimes-range-range-value-anomaly.html?&&    ;   http://www.mrexcel.com/forum/excel-questions/817965-dimension-array-range-anomaly.html  ...[/color]
[color=green]'   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenThingsAsRange'   Gives Empty cells[/color]
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenThingsAsRange.Value
[color=green]'   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenThings[color=darkblue]As[/color]Range.Value'   Gives Empty cells[/color]
 
wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).ClearContents
 
[color=darkblue]Dim[/color] ResizedCellToTableRange As Range
[color=darkblue]Set[/color] ResizedCellToTableRange = wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3)
 
  [color=darkblue]With[/color] ResizedCellToTableRange
  .Value = ScreenThingsAsRange.Value
  [color=darkblue]End[/color] [color=darkblue]With[/color]
 
wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).ClearContents
 
  [color=darkblue]With[/color] ResizedCellToTableRange
  .Value = ScreenCapture() [color=green]'Again a peculiar idea that this works. Somehow Excel Knows what you mean when putting the range values = an Array writen without the ()[/color]
  [color=darkblue]End[/color] [color=darkblue]With[/color]
 
wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).ClearContents
 
[color=darkblue]Let[/color] ResizedCellToTableRange.Value = Evaluate("" & ScreenThingsAsRange.Address & "").Address
 
wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).ClearContents
 
[color=green]'    Let ResizedCellToTableRange.Value = Evaluate("" & ScreenThingsAsRange.Address & "")  ' ... gives zeros... so Post #18 here:-  http://www.excelfox.com/forum/f2/multiple-columns-into-single-column-using-data-text-to-column-1891/index2.html[/color]
[color=darkblue]Let[/color] ResizedCellToTableRange.Value = Evaluate("IF(Row()," & "" & ScreenThings[color=darkblue]As[/color]Range.Address & "" & ")")
 
[color=green]'  Using Screen Thing Array of variuuses (variants)[/color]
  [color=darkblue]For[/color] TableRow = 2 [color=darkblue]To[/color] LastRowTable [color=green]'...go down each row[/color]
    [color=darkblue]Let[/color] ScreenThings(TableRow, 2) = [color=darkblue]CDbl[/color](ScreenThings(TableRow, 2)) [color=green]' ... These two lines are very tricky....  one or[/color]
    [color=green]'Let ScreenThings(TableRow, 2) = Replace(ScreenThings(TableRow, 2), ",", ".")'  ... the other depending on system[/color]
     
    [color=darkblue]If[/color] ScreenThings(TableRow, 2) <> "" And ScreenThings(TableRow, 1) <> "" [color=darkblue]Then[/color] [color=green]'bodge to get away from 0 if no entry in lookUpValuesTable[/color]
      [color=darkblue]Select[/color] [color=darkblue]Case[/color] ScreenThings(TableRow, 3)
      [color=darkblue]Case[/color] "mg", "Milligram", "Milligramm", "Milligram", "milligramm"
      [color=darkblue]Let[/color] ScreenThings(TableRow, 3) = ScreenThings(TableRow, 2) / 1000
 
      [color=darkblue]Case[/color] "µg", "?g", "µg", "Mikrogramm", "Microgram", "Microgramm", "Mikrogram", "Mikrogramms", "Micrograms", "Microgramms", "Mikrograms"
      [color=darkblue]Let[/color] ScreenThings(TableRow, 3) = ScreenThings(TableRow, 2) / 1000000
 
      [color=darkblue]Case[/color] "g", "gram", "gramm", "Kcal", "Kilocal", "kcal", ""
      [color=darkblue]Let[/color] ScreenThings(TableRow, 3) = ScreenThings(TableRow, 2) / 1
      [color=darkblue]End[/color] [color=darkblue]Select[/color]
     
        [color=green]'      Select Case wksLkUpValues.Cells(LkUpR, 22).Value 'Case saltz gegeben[/color]
        [color=green]'      Case "Salz", "salz", "Salt", "salt", "sal", "Sal"  '(dann ist meist ist das stadt Natrium)[/color]
        [color=green]'      Let wksLkUpValues.Cells(LkUpMinR, 22).Resize(1, 3).Value = Array("Natrium", wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, Application.WorksheetFunction.Round(wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, 3))[/color]
        [color=green]'      End Select[/color]
     
      [color=darkblue]If[/color] ScreenThings(TableRow, 3) > 1 [color=darkblue]Then[/color] [color=green]'Bodge, Braces to safegaurd from later . to thousend , umwandel![/color]
      [color=darkblue]Let[/color] ScreenThings(TableRow, 3) = Application.WorksheetFunction.Round(ScreenThings(TableRow, 3), 2)
      [color=darkblue]Else[/color] [color=green]'Numbers < 1 do not seem to suffer from this . , prob!?![/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]Else[/color] [color=green]'Do no do anything for a missing entry[/color]
      [color=darkblue]If[/color] ScreenThings(TableRow, 2) = "" [color=darkblue]Then[/color]
      ScreenThings(TableRow, 3) = "" [color=green]'Bodge for null entry[/color]
      [color=darkblue]Else[/color]
      [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
     
  [color=darkblue]Next[/color] TableRow
 
[color=green]'Trying some Re-Pasting of Table[/color]
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenThings [color=green]'  ....[/color]
[color=darkblue]Let[/color] wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenThings '
 
 
[color=green]'[/color]
'
'            '   Using Capture "Range" Array 1 (wrongly without range)
[color=green]'                For TableRow = 2 To LastRowTable '...go down each row[/color]
[color=green]'                Let ScreenCapture(TableRow, 2) = CSng(ScreenCapture(TableRow, 2)) ' ... These two lines are very tricky....  one or[/color]
[color=green]'                'Let ScreenCapture(TableRow, 2) = Replace(ScreenCapture(TableRow, 2), ",", ".")'  ... the other depending on system[/color]
[color=green]'[/color]
'                If ScreenCapture(TableRow, 2) <> "" And ScreenCapture(TableRow, 1) <> "" Then 'bodge to get away from 0 if no entry in lookUpValuesTable
[color=green]'                  Select Case ScreenCapture(TableRow, 3)[/color]
[color=green]'                  Case "mg", "Milligram", "Milligramm", "Milligram", "milligramm"[/color]
[color=green]'                  Let ScreenCapture(TableRow, 3) = ScreenCapture(TableRow, 2) / 1000[/color]
[color=green]'[/color]
'                  Case "µg", "?g", "µg", "Mikrogramm", "Microgram", "Microgramm", "Mikrogram", "Mikrogramms", "Micrograms", "Microgramms", "Mikrograms"
[color=green]'                  Let ScreenCapture(TableRow, 3) = ScreenCapture(TableRow, 2) / 1000000[/color]
[color=green]'[/color]
'                  Case "g", "gram", "gramm", "Kcal", "Kilocal", "kcal", ""
[color=green]'                  Let ScreenCapture(TableRow, 3) = ScreenCapture(TableRow, 2) / 1[/color]
[color=green]'                  End Select[/color]
[color=green]'[/color]
'                    '      Select Case wksLkUpValues.Cells(LkUpR, 22).Value 'Case saltz gegeben
[color=green]'                    '      Case "Salz", "salz", "Salt", "salt", "sal", "Sal"  '(dann ist meist ist das stadt Natrium)[/color]
[color=green]'                    '      Let wksLkUpValues.Cells(LkUpMinR, 22).Resize(1, 3).Value = Array("Natrium", wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, Application.WorksheetFunction.Round(wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, 3))[/color]
[color=green]'                    '      End Select[/color]
[color=green]'[/color]
'                  If ScreenCapture(TableRow, 3) > 1 Then 'Bodge, Braces to safegaurd from later . to thousend , umwandel!
[color=green]'                  Let ScreenCapture(TableRow, 3) = Application.WorksheetFunction.Round(ScreenCapture(TableRow, 3), 2)[/color]
[color=green]'                  Else 'Numbers < 1 do not seem to suffer from this . , prob!?![/color]
[color=green]'                  End If[/color]
[color=green]'                Else 'Do no do anything for a missing entry[/color]
[color=green]'                  If ScreenCapture(TableRow, 2) = "" Then[/color]
[color=green]'                  ScreenCapture(TableRow, 3) = "" 'Bodge for null entry[/color]
[color=green]'                  Else[/color]
[color=green]'                  End If[/color]
[color=green]'                End If[/color]
[color=green]'[/color]
'              Next TableRow
[color=green]'[/color]
'            'Trying some Re-Pasting of Table
[color=green]'[/color]
'            Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenCapture
[color=green]'            Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenCapture '   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(12, 3).Value = ScreenCapture.Value '.... ScreenCapture is invalid identifier !?[/color]
[color=green]'[/color]
'
'
'
'              '   Using Capture "Range" Array 2 (correctlywith range.value)
[color=green]'                For TableRow = 2 To LastRowTable '...go down each row[/color]
[color=green]'                Let ScreenCapture(TableRow, 2).Value = CSng(ScreenCapture(TableRow, 2).Value) ' ... These two lines are very tricky....  one or[/color]
[color=green]'                'Let ScreenCapture(TableRow, 2).value = Replace(ScreenCapture(TableRow, 2).value, ",", ".")'  ... the other depending on system[/color]
[color=green]'[/color]
'                If ScreenCapture(TableRow, 2).Value <> "" And ScreenCapture(TableRow, 1).Value <> "" Then 'bodge to get away from 0 if no entry in lookUpValuesTable
[color=green]'                  Select Case ScreenCapture(TableRow, 3).Value[/color]
[color=green]'                  Case "mg", "Milligram", "Milligramm", "Milligram", "milligramm"[/color]
[color=green]'                  Let ScreenCapture(TableRow, 3).Value = ScreenCapture(TableRow, 2).Value / 1000[/color]
[color=green]'[/color]
'                  Case "µg", "?g", "µg", "Mikrogramm", "Microgram", "Microgramm", "Mikrogram", "Mikrogramms", "Micrograms", "Microgramms", "Mikrograms"
[color=green]'                  Let ScreenCapture(TableRow, 3).Value = ScreenCapture(TableRow, 2).Value / 1000000[/color]
[color=green]'[/color]
'                  Case "g", "gram", "gramm", "Kcal", "Kilocal", "kcal", ""
[color=green]'                  Let ScreenCapture(TableRow, 3).Value = ScreenCapture(TableRow, 2).Value / 1[/color]
[color=green]'                  End Select[/color]
[color=green]'[/color]
'                    '      Select Case wksLkUpValues.Cells(LkUpR, 22).Value 'Case saltz gegeben
[color=green]'                    '      Case "Salz", "salz", "Salt", "salt", "sal", "Sal"  '(dann ist meist ist das stadt Natrium)[/color]
[color=green]'                    '      Let wksLkUpValues.Cells(LkUpMinR, 22).Resize(1, 3).Value = Array("Natrium", wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, Application.WorksheetFunction.Round(wksLkUpValues.Cells(LkUpR, 23).Value * 0.3933, 3))[/color]
[color=green]'                    '      End Select[/color]
[color=green]'[/color]
'                  If ScreenCapture(TableRow, 3).Value > 1 Then 'Bodge, Braces to safegaurd from later . to thousend , umwandel!
[color=green]'                  Let ScreenCapture(TableRow, 3).Value = Application.WorksheetFunction.Round(ScreenCapture(TableRow, 3).Value, 2)[/color]
[color=green]'                  Else 'Numbers < 1 do not seem to suffer from this . , prob!?![/color]
[color=green]'                  End If[/color]
[color=green]'                Else 'Do no do anything for a missing entry[/color]
[color=green]'                  If ScreenCapture(TableRow, 2).Value = "" Then[/color]
[color=green]'                  ScreenCapture(TableRow, 3).Value = "" 'Bodge for null entry[/color]
[color=green]'                  Else[/color]
[color=green]'                  End If[/color]
[color=green]'                End If[/color]
[color=green]'[/color]
'              Next TableRow
[color=green]'[/color]
'            'Trying some Re-Pasting of Table
[color=green]'[/color]
'            Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3) = ScreenCapture
[color=green]'            Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(LastRowTable, 3).Value = ScreenCapture '   Let wkshtDebTab.Cells(ScnFgsStRow, LastClmTable + 2).Resize(12, 3).Value = ScreenCapture.Value '.... ScreenCapture is invalid identifier !?[/color]
 
 
 
[color=green]'##############################################################[/color]
[color=green]' Put values in Dump, after quick check that table looks ok[/color]
 
 
[color=darkblue]Dim[/color] WksDump [color=darkblue]As[/color] Worksheet
[color=darkblue]Dim[/color] WbkDump [color=darkblue]As[/color] Workbook, DumpName [color=darkblue]As[/color] [color=darkblue]String[/color], DumpNameWindows [color=darkblue]As[/color] [color=darkblue]String[/color] [color=green]'For references to Dump Sheet[/color]
[color=darkblue]Let[/color] DumpName = "11 172x49ExtRowsGruppiertDumpAbDec2014ISSC.xlsx"
[color=darkblue]Set[/color] WbkDump = Workbooks(DumpName)
[color=darkblue]Set[/color] WksDump = WbkDump.Worksheets("Sheet1")
 
    [color=darkblue]Dim[/color] PointPos [color=darkblue]As[/color] [color=darkblue]Long[/color] [color=green]'These three lines are necerssary as Active cell only works for Windows and windows only wants name without bit after . (I.e. no .xlsx)[/color]
    [color=darkblue]Let[/color] PointPos = InStr(1, DumpName, ".")
    [color=darkblue]Let[/color] DumpNameWindows = Mid(DumpName, 1, PointPos - 1)
WksDump.Activate [color=green]'So you can select cell in row 1[/color]
   
[color=green]'  .....  quick check that table looks ok[/color]
wkshtDebTab.Activate
  [color=darkblue]Dim[/color] Response [color=darkblue]As[/color] [color=darkblue]Integer[/color] [color=green]'In VBA Butons "yes is 6, 7 is "no"[/color]
  Response = MsgBox(prompt:="Is Table OK in " & Chr(13) & Chr(10) & DumpNameWindows & " (esp. , . thing?)", Buttons:=vbYesNo, Title:="File Check") [color=green]' Displays a message box with the yes and no options.[/color]
  [color=darkblue]If[/color] Response = vbYes [color=darkblue]Then[/color] [color=green]'Do nothuing, that is to say just carry on after End of If[/color]
  [color=darkblue]Else[/color]
  [color=darkblue]Exit[/color] [color=darkblue]Sub[/color] [color=green]' The no button was selected so stop macro.[/color]
  [color=darkblue]End[/color] [color=darkblue]If[/color]
WksDump.Activate
 
 
[color=darkblue]Dim[/color] DumpC [color=darkblue]As[/color] [color=darkblue]Long[/color], DumpMaxC [color=darkblue]As[/color] [color=darkblue]Long[/color], DumpMinC [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Let[/color] DumpMinC = 8: [color=darkblue]Let[/color] DumpMaxC = 100 [color=green]'Nutrition columns to be included[/color]
 
[color=darkblue]Dim[/color] LkUpR [color=darkblue]As[/color] [color=darkblue]Long[/color], LkUpMaxR [color=darkblue]As[/color] [color=darkblue]Long[/color], LkUpMinR  [color=darkblue]As[/color] [color=darkblue]Long[/color]
[color=darkblue]Let[/color] LkUpMinR = 2: [color=darkblue]Let[/color] LkUpMaxR = LastRowTable [color=green]'Look Uped values for Nutrition columns to be included from debinet[/color]
 
[color=darkblue]Dim[/color] HeaderR As [color=darkblue]Long[/color] [color=green]'Header Rows[/color]
 
  [color=darkblue]For[/color] LkUpR = LkUpMinR [color=darkblue]To[/color] LkUpMaxR [color=darkblue]Step[/color] 1 'Look along Obtained values after manipulating Debinet table
    [color=darkblue]If[/color] ScreenThings(LkUpR, 3) <> "" [color=darkblue]Then[/color] [color=green]'This helps with speed... only do something if a value is there to be inputed.[/color]
      [color=darkblue]For[/color] DumpC = DumpMinC [color=darkblue]To[/color] DumpMaxC [color=darkblue]Step[/color] 1 [color=green]'Work along each column in dump[/color]
        [color=darkblue]For[/color] HeaderR = 1 [color=darkblue]To[/color] 21 [color=darkblue]Step[/color] 1 [color=green]'Go through header spelling variations[/color]
          [color=darkblue]If[/color] ScreenThings(LkUpR, 1) = WksDump.Cells(HeaderR, DumpC).Value [color=darkblue]Then[/color] [color=green]'Look for match in header[/color]
            [color=darkblue]Let[/color] Windows(DumpNameWindows).ActiveCell.Offset(0, DumpC - 1).Value = ScreenThings(LkUpR, 3)
          [color=darkblue]Else[/color] [color=green]'No Header match[/color]
        [color=darkblue]End[/color] [color=darkblue]If[/color]
        [color=darkblue]Next[/color] HeaderR
      [color=darkblue]Next[/color] DumpC
    [color=darkblue]Else[/color] [color=green]'No value to be included[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
  [color=darkblue]Next[/color] LkUpR
 
 
 
 
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'MrExcelDebiNetPutInPetrasDecDump()[/color]

……………………………………………………………………………..

 

[DocAElstein]

EDIT:
. I have in fact just obtained the following with a macro recording which copies into a spreadsheet the entire Web Page which (amongst everything else!) also has the tables of interest to me. So I can write a code to pick out the parts that are there which I want. So I have a temporary solution.
. But I would still prefer a more professional solution of a code along the lines of one using the commands, properties and methods of Microsoft Internet Controls to pick out (or “scrape out” I think is the term used?) the bits I want out of the webpage HTML code.

. Can anyone can help get me started on that one?

. Thanks again
Alan

……………………………………………………







Code from Macro recording:

[color=darkblue]Sub[/color] Apfel_F110000_ByMacroRecorder()
 
    [color=darkblue]With[/color] ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.ernaehrung.de/lebensmittel/de/F110000/Apfel.php", Destination _
        :=Range("$A$1"))
        .Name = "Apfel"
        .FieldNames = [color=darkblue]True[/color]
        .RowNumbers = [color=darkblue]False[/color]
        .FillAdjacentFormulas = [color=darkblue]False[/color]
        .PreserveFormatting = [color=darkblue]True[/color]
        .RefreshOnFileOpen = [color=darkblue]False[/color]
        .BackgroundQuery = [color=darkblue]True[/color]
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = [color=darkblue]False[/color]
        .SaveData = [color=darkblue]True[/color]
        .AdjustColumnWidth = [color=darkblue]True[/color]
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = [color=darkblue]True[/color]
        .WebConsecutiveDelimitersAsOne = [color=darkblue]True[/color]
        .WebSingleBlockTextImport = [color=darkblue]False[/color]
        .WebDisableDateRecognition = [color=darkblue]False[/color]
        .WebDisableRedirections = [color=darkblue]False[/color]
        .Refresh BackgroundQuery:=[color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
 
[color=darkblue]End[/color] [color=darkblue]Sub[/color] [color=green]'Apfel_F110000_ByMacroRecorder()[/color]

 

[jbeaucaire]

It seems like that last macro is pretty much how I would do it. Only difference is I would run that macro on a "temp" sheet, then scrap the data out that I need, then delete the sheet, all in the background, usually quick enough to look as elegant as anything else.

I ran your macro and it grabs a good set of data, so you need only define the "start" and "end" characteristics of the data you want and just grab that into your main sheet.

 

[pike]

another alterative way with two library refernces

Option Explicit
 'reference to Microsoft Internet Controls
 'reference to Microsoft HTML Object Library

Sub Web_Table_Option_One()
Dim xml    As Object
Dim html   As Object
Dim objTable As Object
Dim result As String
Dim lRow As Long
Dim lngTable As Long
Dim lngRow As Long
Dim lngCol As Long
Dim ActRw As Long
Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
With xml
.Open "GET", "http://www.ernaehrung.de/lebensmittel/de/F110000/Apfel.php", False
.send
End With
result = xml.responseText
Set html = CreateObject("htmlfile")
html.body.innerHTML = result
Set objTable = html.getElementsByTagName("table")
 For lngTable = 0 To objTable.Length - 1
        For lngRow = 0 To objTable(lngTable).Rows.Length - 1
            For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                ThisWorkbook.Sheets("Sheet2").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
            Next lngCol
        Next lngRow
        ActRw = ActRw + objTable(lngTable).Rows.Length + 1
    Next lngTable
End Sub

 

[ZVI]

In the above code this can be used to get Vitamine table only
Set objTable = html.All.Item("container2").getElementsByTagName("table")

For IE object it looks like this:
Set objTable = IE.Document.All.Item("container2").getElementsByTagName("table") '(0)

where "container2" comes from the site's HTML code of the required table: div id="container2"