Import Sharepoint List into Excel Using VBA Only

Import SharePoint List into Excel only using VBA

Macro that will import a SharePoint list directly into Excel.  Below VBA will pull Sharepoint List into Excel as a table.  Required inputs for the VBA is the Sharepoint’s URL, GUID and decoded GUID.

https://www.vba-market.com/ImportSharepointList_toExcel.xlsm

 

You can get the GUID from the Library Settings page: (will look something like http://sp.web.com/Lists/ListName/_layouts/listedit.aspx?List=%7BF7B36223%2D487D%2D4550%2D8186%2DB286F1D4698E%7D)

Then you need to decode the GUID, by google searching for URL Decoder.

GUID: (%7BF7B36223%2D487D%2D4550%2D8186%2DB286F1D4698E%7D)

Decoded GUID: {F7B36223-487D-4550-8186-B286F1D4698E}

Use the decoded GUID in the VBA macro.

src(1) = "F7B36223-487D-4550-8186-B286F1D4698E"

Update src(0) with your sharepoint list URL + _vti_bin at the end of the URL.

src(0) = "https://sp.com/sites/myList/_vti_bin"

Sub ImportSharepointList_toExcel()
Dim ws As Worksheet
Dim objListObj As ListObject
Set ws = ThisWorkbook.Worksheets(1)
Dim src(1) As Variant

'http://sp.web.com/Lists/ListName/_layouts/listedit.aspx?List=%7BF7B36223%2D487D%2D4550%2D8186%2DB286F1D4698E%7D
'GUID = %7BF7B36223%2D487D%2D4550%2D8186%2DB286F1D4698E%7D
'URL Decode conversion:  {F7B36223-487D-4550-8186-B286F1D4698E}

src(0) = "https://sp.com/sites/myList/_vti_bin"
src(1) = "F7B36223-487D-4550-8186-B286F1D4698E"
ws.ListObjects.Add xlSrcExternal, src, True, xlYes, ws.Range("A1")

End Sub


VBA to loop all files in a folder

VBA macro that will open all Excel files in a folder

Macro that will open all Excel files in a folder.  This functionality can be used to aggregate multiple workbooks into one or pull data from all workbooks in a folder.  This demo example only opens the files.  Within the loop you will add your logic to be performed on the opened workbook.

https://www.vba-market.com/LoopAllFiles_inFolder.xlsm

Sub LoopAllFiles_inFolder()
MsgBox ("Select folder with files to loop")
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    On Error Resume Next
    strpath = .SelectedItems(1)
    Err.Clear
    On Error GoTo 0
End With
If Right(strpath, 1) <> "\" Then strpath = strpath + "\"
ChDir strpath
strextend = Dir("*.xls*")

Do While strextend <> ""
    Set wb1 = Workbooks.Open(strpath & strextend)
    wb1.Activate
    ' add logic to be performed on open workbooks here

strextend = Dir
Loop

End Sub


VBA insert excel table into email message

How to insert an Excel table into the body of an email message.

VBA macro that sends an Outlook email and inserts an Excel table into the body of the email.

https://www.vba-market.com/EmailDemo.xlsm

Sub Email()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    rws = ActiveSheet.UsedRange.Rows.Count
    cols = ActiveSheet.UsedRange.Columns.Count
    Set rng = Range(Cells(1, 1), Cells(rws, cols))
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = "helpdesk@vba-market.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .display   'or use .send
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

This part is where the email details are created.  This is where you can edit the email message details.

With OutMail
        .To = "helpdesk@vba-market.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .display   'or use .send
    End With


Excel Macro pull historical stock market data

Excel Macro to pull historical stock market data

Macro that Automatically pulls historical stock market data from Google finance.  Input list of tickers and the macro will go pull the historical data for the specified date range.  Allows you to easily pull all historical data for multiple tickers without having to manually search and download tickers one at a time.


**Note: Looks like Google has decided to block automated queries for historical data.  This may be temporary or permanent not sure.  They have be locking down on their stock market data because companies have been using the data to sell which has ruined the service for everyone looks like.  This is the message from Google after running the Macro.

VBA Pull Stock Prices

  
Sub StockMarketDataDownload()

Application.ScreenUpdating = False
 On Error Resume Next

Dim Loc
 Dim ws, ws2, ws3 As Worksheet
 Dim EndDate, StartDate As Date
 Dim Symbol, qurl As String

'Create worksheets
 Sheets("Tickers").Select
 Set ws = ActiveSheet
 Sheets("Data").Select
 Set ws2 = ActiveSheet
 ws2.Cells.Clear

ws.Select
 StartDate = Range("B2").Value
 EndDate = Range("B3").Value

' Set Range for Loop
 Dim i As Integer
 Dim tickerEnd As Integer
 Cells(5, 1).Select
 Range(Selection, Selection.End(xlDown)).Select
 tickerEnd = Selection.Rows.Count
 tickerEnd = tickerEnd

 Dim j As Integer
 Dim idate As Integer
 Dim iclose As Integer

 'Loop through Column

For i = 2 To tickerEnd
 j = 4 + i

 iclose = i + 1
 idate = 2
 ws2.Cells.Clear
 Range("A1").Select
 ws.Select

Symbol = Cells(j, 1).Value

' ' qurl = "http://www.google.com/finance/historical?q=" & Symbol & "&output=csv"
'https://finance.google.com/finance/historical?cid=304466804484872&startdate=Aug+1%2C+2016&enddate=Oct+1%2C+2017&num=30&ei=QwXRWeCqEYiljAGdiJWoBA
'https://finance.google.com/finance/historical?q=SPY&startdate=Aug+1%2C+2016&enddate=Oct+1%2C+2017&num=30&output=csv
'https://finance.google.com/finance/historical?q=SPY&startdate=Jan+1+2016&enddate=Oct+1C+2017&num=30&output=csv

qurl = "https://finance.google.com/finance/historical?q=" _
& Symbol & "&startdate=" & Format(StartDate, "mmm") & "+" & Day(StartDate) & "+" & Year(StartDate) & _
"&enddate=" & Format(EndDate, "mmm") & "+" & Day(EndDate) & "+" & Year(EndDate) & "&num=30&output=csv"

'MsgBox qurl
 ws2.Select

Query:
 With Sheets("Data").QueryTables.Add(Connection:="URL;" & qurl, Destination:=Sheets("Data").Range("A1"))
 .BackgroundQuery = True
 .TablesOnlyFromHTML = False
 .Refresh BackgroundQuery:=False
 .SaveData = False
 End With

Sheets("Data").Range("A1").CurrentRegion.TextToColumns Destination:=Sheets("Data").Range("A1"), DataType:=xlDelimited, _
 TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
 Semicolon:=False, Comma:=True, Space:=False, other:=False

 'Paste date
 Cells.Select
 Selection.Copy
 Sheets.Add After:=Sheets(Sheets.Count)
 ActiveSheet.Paste
 ActiveSheet.Name = Symbol
 Columns("A:A").Select
 Selection.ColumnWidth = 14.29
 Range("A1").Select

 Next i
Application.ScreenUpdating = True
On Error GoTo 0

ErrorHandler:

End Sub


VBA loop HTML page elements by tag name

How to Loop webpage to find a specific element

This VBA code can be used to loop all the data on a webpage looking for a specific element.  This element can then be actioned.  Such actions as inputting value in text box, clicking button, scraping values, etc.  You have to lookup the name or ID in the HTML so you can tell Excel which element on the page to interact with.

https://www.vba-market.com/IEAutomationExample.xlsm

Sub scrape_loop()
Dim doc, hcol, text As Variant
Dim ie As SHDocVw.InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate ("https://www.google.com")
Do While ie.ReadyState <> READYSTATE_COMPLETE
    DoEvents
    Loop
    While ie.Busy
    DoEvents
    Wend
Set doc = ie.Document
Set hcol = doc.getElementsByTagName("input")
    For Each text In hcol
         If text.ID = "lst-ib" Then
              text.Value = "www.vba-market.com"
        End If
    Next
Application.Wait (Now + #12:00:02 AM#)
Set doc = ie.Document
Set hcol = doc.getElementsByTagName("button")
    For Each text In hcol
         If text.ID = "_fZl" Then
              text.Click
        End If
    Next
End Sub

Set hcol = doc.getElementsByTagName("button")

This should be set to the Tag type your looping such as input, button, td, etc.

The macro loops all the tags of the specified type.  You can then check if the name, id, innerHTML, etc of the element matches what you’re looking for.

If text.ID = "lst-ib" Then

If text.title = "Search" then

The ID, name, title, etc can be found in View Source of the webpage (right click inspect element).  Use the select tool to grab the element you’re looking for.

Then read through the HTML code to find the ID, name, title, innerHTML, etc.

search

Set doc = ie.Document
Set hcol = doc.getElementsByTagName("input")
    For Each text In hcol
         If text.ID = "lst-ib" Then
              text.Value = "www.vba-market.com"
        End If
    Next

Then use this to loop the tags to find the input Search box.  Once it is found the value “www.vba-market.com” is input into the Search box.

*Note:  Microsoft Internet Controls Reference must be enabled.


Excel VBA web scraper Google finance

Excel VBA web scraper Google finance

Macro that scrapes web data from Google Finance page.  You input a list of Tickers and run the macro which goes to Google finance and pulls the stats for the list of tickers.

 

Google Finance Web Scraper (179 downloads)

 

Output of macro:

web-scraper-google-finance

Option Explicit
Sub WebScrape()
Dim tickerLength, nextIs, i As Long
Dim doc, hcol, text As Variant
Dim ticker As String
Dim currentInnerHtml As String
currentInnerHtml = ""
Dim ie As SHDocVw.InternetExplorer
tickerLength = WorksheetFunction.CountA(Columns(1))
For i = 2 To tickerLength - 1
ticker = Cells(i + 1, 1).Value
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate ("https://www.google.com/finance?q=" & ticker)
Do While ie.ReadyState <> READYSTATE_COMPLETE
    DoEvents
    Loop
    While ie.Busy
    DoEvents
    Wend
    Set doc = ie.Document
    Set hcol = doc.getElementsByTagName("td")
        For Each text In hcol

            If currentInnerHtml = "Range" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 2).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "52 week" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 3).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "Open" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 4).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "volavg" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 5).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "Mkt" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 6).Value = text.innerhtml
                End If
             ElseIf currentInnerHtml = "PE" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 7).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "DivY" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 8).Value = text.innerhtml
                End If
             ElseIf currentInnerHtml = "EPS" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 9).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "Shares" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 10).Value = text.innerhtml
                End If
             ElseIf currentInnerHtml = "Beta" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 11).Value = text.innerhtml
                End If
            ElseIf currentInnerHtml = "Inst" Then
                currentInnerHtml = ""
                If InStr(1, text.innerhtml, "<", vbTextCompare) = 0 And InStr(1, text.innerhtml, "&", vbTextCompare) = 0 Then
                    Cells(i + 1, 12).Value = text.innerhtml
                End If
            End If

            If InStr(1, text.innerhtml, "Range", vbTextCompare) > 0 Then
                currentInnerHtml = "Range"
            ElseIf InStr(1, text.innerhtml, "52 week", vbTextCompare) > 0 Then
                 currentInnerHtml = "52 week"
            ElseIf InStr(1, text.innerhtml, "Open", vbTextCompare) > 0 Then
                currentInnerHtml = "Open"
            ElseIf InStr(1, text.innerhtml, "Vol", vbTextCompare) > 0 Then
                currentInnerHtml = "volavg"
            ElseIf InStr(1, text.innerhtml, "Mkt cap", vbTextCompare) > 0 Then
                currentInnerHtml = "Mkt"
            ElseIf InStr(1, text.innerhtml, "P/E", vbTextCompare) > 0 Then
                currentInnerHtml = "PE"
            ElseIf InStr(1, text.innerhtml, "Div/yield", vbTextCompare) > 0 Then
                currentInnerHtml = "DivY"
            ElseIf InStr(1, text.innerhtml, "EPS", vbTextCompare) > 0 Then
                currentInnerHtml = "EPS"
            ElseIf InStr(1, text.innerhtml, "Shares", vbTextCompare) > 0 Then
                currentInnerHtml = "Shares"
            ElseIf InStr(1, text.innerhtml, "Beta", vbTextCompare) > 0 Then
                currentInnerHtml = "Beta"
            ElseIf InStr(1, text.innerhtml, "Inst", vbTextCompare) > 0 Then
                currentInnerHtml = "Inst"
            End If
        Next

Next i
End Sub

*Note: Microsoft Internet Controls Reference must be enabled