Extracting Data from Website to Excel

Sometimes we need to extract some stock price related info from website to Excel worksheet. Here is the VBA Code to extract info from Yahoo Finance:


Sub getInfoOnine()
Dim qt As QueryTable
Set qt = ActiveSheet.QueryTables.Add(Connection:="Url;http://finance.yahoo.com/q?s=infy", Destination:=Range("B2"))
With qt
        .Name = "Getting online data"
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingAll
        .WebTables = "1,2,3"
        .EnableRefresh = True
        .RefreshPeriod = 10
        .Refresh
End With
End Sub

Example Messagebox Function in VBA

It's a sample code for messagebox function in vba for excel spreadsheet

Sub diplaymessageBox()
Dim stranswer As VbMsgBoxResult
stranswer = MsgBox("Would you like to colour the cell?", vbQuestion + vbYesNo, "Select Option")
If stranswer = vbYes Then
        Selection.Interior.ColorIndex = 8
    End If
End Sub

Importing Txt file into Excel

VBA Code for importing a text file into excel spredaheet

Sub importFile()

Dim filepathName As String

filepathName = InputBox("Enter complete filepath name:")

    With ActiveSheet.QueryTables.Add(Connection:="text;" & filepathName, Destination:=Range("A1"))
        .Name = "Excel Importing Text File"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlFixedWidth
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
   
    End With

End Sub

Automated Search Option for Spreadsheet

Following VBA code is  an extension of existing Find function in  Excel Spreadsheet. Though normal Find

function you have to find desired data in each sheet seperately. Through below mentioned code you can get

the result of searched value across all cells of spreadsheets in an Excel Workbook. Wherever the code will

find the data, it will automatically bold , enlarge that cell and save the worksheet.


Sub searchthroughSheet()
Dim mydata As Variant
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Dim c As range
mydata = InputBox("Enter your value to search:")
On Error Resume Next
For Each ws In wb.Worksheets
With Worksheets(ws.Index).Cells
Sheets(ws.Index).Select
    Set c = .find(mydata, LookIn:=xlValues)
    If Not c Is Nothing Then
            firstaddress = c.Address
            Do
                MsgBox "Match found in" & Worksheets(ws.Index).Name & c.Address
                range(c.Address).Select
                Selection.Font.Bold = True
                Selection.Font.Size = 20
                ActiveWorkbook.Save
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With
Next ws
End Sub

Copy Specific Cells in a Worksheet by VBA

'VBA  Code to copy specified cells from all the files in a folder

Option Explicit
Dim objFso As Object, pathname As String, eachfile, objFolder As Object, wb As Workbook
Sub getDatafromAnotherfile()
Set objFso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
pathname = "C:\Users\AJS-Client\Desktop\Check\GMU-Dubai21.12.2013"
Set objFolder = objFso.GetFolder(pathname)
For Each eachfile In objFolder.Files
MsgBox objFso.GetExtensionName(eachfile)
   If objFso.GetExtensionName(eachfile) = "xls" Then
 
        Call Openfile(eachfile)
   End If
 
Next
Set wb = Nothing
End Sub

Public Sub Openfile(eachfile)


Workbooks.Open eachfile

ActiveWorkbook.Sheets(1).Range("A2:C2").Copy wb.Sheets(1).Range("A2")
ActiveWorkbook.Close


End Sub

Dynamic Dashboard Report Without VBA

Dashboard Report(Above)
This is a chart of Pollution Control department that compares the city by month in following categories:

Average Precipitation,Average Temperature,Percent Sunshine,Average Wind Speed. We have used option button,vlook-up and name range generate this dynamic Dashboard 

Get Next Blank Cell in a Spreadsheet

VBA Code for finding next blankcell in a Spreadsheet:





Sub getnextblankcell()
Dim selrange, nextrange, result As Range
Dim dir As String
On Error Resume Next
dir = InputBox("Enter direction:Up/Down/Left/Right")
Set selrange = Application.InputBox("Select Range:", "Choose", Type:=8)
    If dir = "Up" Then
        Set nextrange = selrange.End(xlUp)
        Set result = nextrange.Offset(-1, 0)
        result.Select
    ElseIf dir = "Down" Then
        Set nextrange = selrange.End(xlDown)
        Set result = nextrange.Offset(1, 0)
        result.Select
    ElseIf dir = "Right" Then
        Set nextrange = selrange.End(xlToRight)
        Set result = nextrange.Offset(0, 1)
        result.Select
    ElseIf dir = "Left" Then
        Set nextrange = selrange.End(xlToLeft)
        Set result = nextrange.Offset(0, -1)
        result.Select
        Set result = Nothing
    End If
End Sub

For further resources

Code for Retrieving Data from SQL Server 2005 to Excel Spreadheet

Altough you can retrieve data from SqlServer 2005 to excel spreadsheet under   'Get External Data ' option; sometimes you need to run your own SQL query to pull back required fields from different tables to work with.

Here is  a simple VBA code to run your own SQL query  using SQL  Server 2005's in-bulit driver SQLOLEDB.1


Option Explicit
Sub retrievedata()
Dim con As New ADODB.Connection
Dim rst As New ADODB.Recordset
Application.ScreenUpdating = False
On Error Resume Next
    con.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Data Source=NEW\SQLEXPRESS;"
    con.Open
    rst.ActiveConnection = con
    rst.Source = "Select * from Member where Gender='F' "
    rst.Open
    Range("A2").CopyFromRecordset rst
    rst.Close
    con.Close
    Set rst = Nothing
    Set con = Nothing
    Application.ScreenUpdating = True
End Sub

Creating a complex Pivot Table

There is a budget spreadsheet mentioned below:

VBA code for creating pivot table with variance analysis:

Sub Macro1()

'
' Macro1 Macro
'

'

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        Range("A1").CurrentRegion.Address, Version:=xlPivotTableVersion12).CreatePivotTable _
        TableDestination:="", TableName:="PivotTable1", DefaultVersion:= _
        xlPivotTableVersion12
    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
    ActiveSheet.Cells(3, 1).Select
    With ActiveSheet.PivotTables("PivotTable1")
        .PivotFields("Department").Orientation = xlRowField
        .PivotFields("Division").Orientation = xlPageField
        .PivotFields("Category").Orientation = xlPageField
        .PivotFields("Budget").Orientation = xlDataField
       
        .PivotFields("Actual").Orientation = xlDataField
       
        .PivotFields("Month").Orientation = xlColumnField
        .DataPivotField.Orientation = xlRowField
        .CalculatedFields.Add "Variance", "=Budget-Actual"
        .PivotFields("Variance").Orientation = xlDataField
        .DataBodyRange.NumberFormat = "0,000"
        .TableStyle = TableStyle2
        .DisplayFieldCaptions = False
        .PivotFields("Sum of Budget").Caption = " Budget"
        .PivotFields("Sum of Actual").Caption = " Actual"
        .PivotFields("Sum of Variance").Caption = " Variance"
     End With
   
End Sub

Summation of unique no. in a Spreadsheet range

VBA code for summation of unique no.s in an excel spreadsheet range:


Function uniquesum(Rg As range)
    Dim rng As range
    Dim ccell As New Collection
    Dim var As Variant
    On Error Resume Next
For Each rng In Rg
ccell.add rng.Value, CStr(rng.Value)
Next rng
For Each var In ccell
uniquesum = var + uniquesum
Next var
End Function

Representing Dynamic Chart for Survey Data

Whenever you need to draw dynamic chart in a userform depending on parameters & factors of survey as mentioned above,VBA macro code is mentioned below.You will have to select one parameter at a time mentioned at the left hand side of the chart.The only requirement for this code is to set focus of your cursors on data points on an excel spreadsheet and to load an image control in form

Private Sub UserForm_initialize()
Call showGraph

End Sub


Sub showGraph()
Dim currentrow As Long
Dim currentchart As Chart
Dim pathname As String
Dim chartheader, datasource, chartdatasource As Range
   currentrow = ActiveCell.Row
    On Error GoTo Errorhandler

    If currentrow <= 1 Then
       MsgBox "Move cell pointer to a row that contains data of Row Labels"
    End If
   
    Set chartheader = ActiveSheet.Range("A1:F1")
    Set datasource = ActiveSheet.Range(Cells(currentrow, 1), Cells(currentrow, 6))
   
    Set chartdatasource = Union(chartheader, datasource)
   
    Range(chartdatasource.Address).Select
    ActiveSheet.Shapes.AddChart.Select
   
    ActiveChart.SetSourceData Source:=chartdatasource, PlotBy:=xlRows
    ActiveChart.ChartType = xlColumnClustered

        pathname = ThisWorkbook.Path & "\temp.gif"
        If Not Dir(pathname) = "" Then
               Kill pathname
            End If
    ActiveChart.Export Filename:=pathname, filtername:="gif"
   
   
    pathname = ThisWorkbook.Path & "\temp.gif"
    UserForm1.Image1.Picture = LoadPicture(pathname)
   
        ActiveSheet.ChartObjects.Delete
   
   
    Exit Sub
Errorhandler:
    MsgBox "Error description" & Err.Description
End Sub

Automated Data entry into Spreadsheet through Userform

This is a simple data entry form for a spredsheet wilth two columns Product & Price. VBA Code for dataentry into spredsheet through userform

Private Sub Enter_Click()
Dim nextrow As Long
Sheets("sheet1").Activate
nextrow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
    If txtproduct.Text = "" Then
        MsgBox "Enter a Product name"
       
    End If
    Cells(nextrow, 1) = txtproduct.Text
    If txtprice.Text = "" Then
    MsgBox "Enter a Price"
    End If
    Cells(nextrow, 2) = txtprice.Text
End Sub
This automated concept is useful for dataentry when there are large no. of cloumns in a spreadsheet.

Highlight duplicate records in a Spreadsheet Range

VBA Macro code for highlighting duplicate records in a spreadsheet



Sub showduplicate()
Dim rng As Range
Dim cell As Variant
Set rng = Application.InputBox("Select your Range", "My range", Type:=8)

    For Each cell In rng
        If WorksheetFunction.CountIf(rng, cell.Value) > 1 Then
        cell.Interior.ColorIndex = 16
        End If
    Next cell
End Sub

Example for Worksheetfunction.trend()

You can use TREND for polynomial curve fitting by regressing against the same variable raised to different powers. For example, suppose column A contains y-values and column B contains x-values. You can enter x^2 in column C, x^3 in column D, and so on, and then regress columns B through D against column A.


Simplae VBA test code

Sub test()
Dim knowny, knownx, myval As Variant
Dim newx As Variant
On Error Resume Next
knowny = Array(2, 4, 6, 8, 10)
knownx = Array(1, 2, 3, 4, 5)
newx = Array(8)
myval = Application.WorksheetFunction.Trend(knowny, knownx, newx)
MsgBox myval(1)
End Sub

How to Use R1C1 format

VBA  macro code to calculate average in a spreadsheet :



Sub calcaverage()
Range("D1").Select
ActiveCell.Value = "Average"
ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell.Offset(0, -2))
        ActiveCell.FormulaR1C1 = "=Average(RC[-3],RC[-2])"
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub

To Get Values from a Chart using VBA

Macro Code to retrieve source data from chart in a spreadsheet:


Sub getchartValues()
Dim numOfRows As Integer
Dim X As Object
On Error Resume Next
        temp = 2
        numOfRows = UBound(ActiveChart.SeriesCollection(1).XValues)
       
        For Each X In ActiveChart.SeriesCollection
        'Sets the name of each seriescollection
        Sheets("sheet1").Cells(1, temp) = X.Name
       
            With Sheets("Sheet1")
            'Sets all x-axis unit name vertically
                .Range(.Cells(2, 1), .Cells(numOfRows, 1)) = Application.Transpose(ActiveChart.SeriesCollection(1).XValues)
            End With
            With Sheets("Sheet1")
            'sets all x-axis value horizontally
                .Range(.Cells(2, temp), .Cells(numOfRows, temp)) = Application.Transpose(X.Values)
            End With


            temp = temp + 1
        Next X
       
End Sub

Display Chart in User Form via VBA

Whenver you want to display chart in user form; create chart on the basis of collated data    in another spreadsheet.
Use VBA code to display that chart into User form and then hide that  spredsheet.

VBA code for that is as follows:

Option Explicit
Dim chartnum As Integer
Private Sub UserForm_Initialize()
    chartnum = 1
    updatechart
End Sub
Private Sub updatechart()
    Dim CurrentChart As Chart
    Dim Fname As String

   
    Set CurrentChart = Sheets("Charts").ChartObjects(chartnum).Chart
    CurrentChart.Parent.Width = 390
    CurrentChart.Parent.Height = 190
    Fname = ThisWorkbook.Path & "\temp.gif"
    CurrentChart.Export Filename:=Fname, FilterName:="GIF"
    Image1.Picture = LoadPicture(Fname)
End Sub

Sort Worksheet using VBA

When you have more than 10 worksheets in your excel file, it's very urgent to sort these sheets on the basis of their sheet name so that we can find them very easily.

VBA code for that is as follows:


Sub sortSheet()
Dim sheetcount, a, b As Integer
Application.ScreenUpdating = False
sheetcount = Worksheets.Count
If sheetcount = 1 Then Exit Sub
For a = 1 To sheetcount - 1
    For b = a + 1 To sheetcount
    If Worksheets(b).Name < Worksheets(a).Name Then
    Worksheets(b).Move before:=Worksheets(a)
    End If
    Next b
Next a
Application.ScreenUpdating = True
End Sub

Sorting Spreadsheet Data using VBA

Sometimes you need to display top 10 sales performers in your spreadsheet out of  thousand records.
VBA code for this operation is as follows:





Sub topTen()
Dim rng As Range
'Remove any existing Sort
ActiveSheet.Sort.SortFields.Clear
'Remove any existing filter
If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.AutoFilterMode = False
End If
Set rng = Application.InputBox("My Range", "Select Range to Sort", Type:=8)
Range("A1").AutoFilter Field:=4, Criteria1:=10, Operator:=xlTop10Items
Range(rng.Address).Select
'Sorting of entire sheet on the basisof column D1
Selection.Sort key1:=Range("D1"), order1:=xlDescending
End Sub

Finding Square of a Range

Vba code:


Sub chcksquare()
Dim rcount, tempval, tempcount As Integer
Dim rng As Range
Set rng = Application.InputBox("Select Range", "My Range", Type:=8)
rcount = rng.Rows.Count
Do
tempval = ActiveCell.Offset(tempcount, 0)
ActiveCell.Offset(tempcount, 1).Formula = "=" & tempval & "*" & tempval
tempcount = tempcount + 1
Loop Until tempcount = rcount
End Sub